Theory Auxiliary

(*  Title:      Jinja/Common/Basis.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 TU Muenchen
*)

chapter ‹Jinja Source Language \label{cha:j}›

section ‹Auxiliary Definitions›

theory Auxiliary imports Main begin
(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j  m) = (n + i  m  n + j  m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j)  m) = (Suc(n + i)  m  Suc(n + j)  m)"
(*<*)by arith(*>*)


notation Some  ("(_)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
 Cons_eq_map_conv [iff]
(*>*)


subsection distinct_fst›
 
definition distinct_fst  :: "('a × 'b) list  bool"
where
  "distinct_fst    distinct  map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs  (y. (k,y)  set kxs))"
(*<*)
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
(*>*)
(*
lemma distinct_fst_append:
 "⟦ distinct_fst kxs'; distinct_fst kxs; ∀(k,x) ∈ set kxs. ∀(k',x') ∈ set kxs'. k' ≠ k ⟧
  ⟹ distinct_fst(kxs @ kxs')"
by (induct kxs) (auto dest: fst_in_set_lemma)

lemma distinct_fst_map_inj:
  "⟦ distinct_fst kxs; inj f ⟧ ⟹ distinct_fst (map (λ(k,x). (f k, g k x)) kxs)"
by (induct kxs) (auto dest: fst_in_set_lemma simp: inj_eq)
*)

lemma map_of_SomeI:
  " distinct_fst kxs; (k,x)  set kxs   map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)


subsection ‹Using @{term list_all2} for relations›

definition fun_of :: "('a × 'b) set  'a  'b  bool"
where
  "fun_of S  λx y. (x,y)  S"

text ‹Convenience lemmas›
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) = 
   ((x,y)  S  list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys = 
  (z zs. ys = z#zs  (x,z)  S  list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) = 
  (z zs. xs = z#zs  (z,y)  S  list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(x. (x,x)  S)  list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  " (x y. (x,y)  S; (y,x)  T  x = y); 
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs   xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans: 
  " a b c. (a,b)  R; (b,c)  S  (a,c)  T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs 
   list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  " i<size xs; list_all2 (fun_of S) xs ys; (x,y)  S  
   list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  " list_all2 (fun_of S) xs ys; p < size xs   (xs!p,ys!p)  S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  " length a = length b; n. n < length a  (a!n,b!n)  S   list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)

end

Theory Type

(*  Title:      Jinja/Common/Type.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Jinja types›

theory Type imports Auxiliary begin

type_synonym cname = string ― ‹class names›
type_synonym mname = string ― ‹method name›
type_synonym vname = string ― ‹names for local/field variables›

definition Object :: cname
where
  "Object  ''Object''"

definition this :: vname
where
  "this  ''this''"

― ‹types›
datatype ty
  = Void          ― ‹type of statements›
  | Boolean
  | Integer
  | NT            ― ‹null type›
  | Class cname   ― ‹class type›

definition is_refT :: "ty  bool"
where
  "is_refT T    T = NT  (C. T = Class C)"

lemma [iff]: "is_refT NT"
(*<*)by(simp add:is_refT_def)(*>*)

lemma [iff]: "is_refT(Class C)"
(*<*)by(simp add:is_refT_def)(*>*)

lemma refTE:
  "is_refT T; T = NT  P; C. T = Class C  P   P"
(*<*)by (auto simp add: is_refT_def)(*>*)

lemma not_refTE:
  " ¬is_refT T; T = Void  T = Boolean  T = Integer  P   P"
(*<*)by (cases T, auto simp add: is_refT_def)(*>*)

end

Theory Decl

(*  Title:      HOL/MicroJava/J/Decl.thy

    Author:     David von Oheimb
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Class Declarations and Programs›

theory Decl imports Type begin

type_synonym 
  fdecl    = "vname × ty"        ― ‹field declaration›
type_synonym
  'm mdecl = "mname × ty list × ty × 'm"     ― ‹method = name, arg.\ types, return type, body›
type_synonym
  'm "class" = "cname × fdecl list × 'm mdecl list"       ― ‹class = superclass, fields, methods›
type_synonym
  'm cdecl = "cname × 'm class"  ― ‹class declaration›
type_synonym
  'm prog  = "'m cdecl list"     ― ‹program›

(*<*)
translations
  (type) "fdecl"   <= (type) "vname × ty"
  (type) "'c mdecl" <= (type) "mname × ty list × ty × 'c"
  (type) "'c class" <= (type) "cname × fdecl list × ('c mdecl) list"
  (type) "'c cdecl" <= (type) "cname × ('c class)"
  (type) "'c prog" <= (type) "('c cdecl) list"
(*>*)

definition "class" :: "'m prog  cname  'm class"
where
  "class    map_of"

definition is_class :: "'m prog  cname  bool"
where
  "is_class P C    class P C  None"

lemma finite_is_class: "finite {C. is_class P C}"

(*<*)
apply (unfold is_class_def class_def)
apply (fold dom_def)
apply (rule finite_dom_map_of)
done
(*>*)

definition is_type :: "'m prog  ty  bool"
where
  "is_type P T  
  (case T of Void  True | Boolean  True | Integer  True | NT  True
   | Class C  is_class P C)"

lemma is_type_simps [simp]:
  "is_type P Void  is_type P Boolean  is_type P Integer 
  is_type P NT  is_type P (Class C) = is_class P C"
(*<*)by(simp add:is_type_def)(*>*)


abbreviation
  "types P == Collect (is_type P)"

end

Theory TypeRel

(*  Title:      Jinja/Common/TypeRel.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Relations between Jinja Types›

theory TypeRel imports 
  "HOL-Library.Transitive_Closure_Table"
  Decl 
begin

subsection‹The subclass relations›

inductive_set
  subcls1 :: "'m prog  (cname × cname) set"
  and subcls1' :: "'m prog  [cname, cname]  bool" ("_  _ 1 _" [71,71,71] 70)
  for P :: "'m prog"
where
  "P  C  1 D  (C,D)  subcls1 P"
| subcls1I: "class P C = Some (D,rest); C  Object  P  C 1 D"

abbreviation
  subcls  :: "'m prog  [cname, cname]  bool" ("_  _ * _"  [71,71,71] 70)
  where "P  C  *  D  (C,D)  (subcls1 P)*"

lemma subcls1D: "P  C 1 D  C  Object  (fs ms. class P C = Some (D,fs,ms))"
(*<*)by(erule subcls1.induct)(fastforce simp add:is_class_def)(*>*)

lemma [iff]: "¬ P  Object 1 C"
(*<*)by(fastforce dest:subcls1D)(*>*)

lemma [iff]: "(P  Object * C) = (C = Object)"
(*<*)
apply(rule iffI)
 apply(erule converse_rtranclE)
  apply simp_all
done
(*>*)

lemma subcls1_def2:
  "subcls1 P =
     (SIGMA C:{C. is_class P C}. {D. CObject  fst (the (class P C))=D})"
(*<*)
  by (fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
(*>*)

lemma finite_subcls1: "finite (subcls1 P)"
(*<*)
apply (simp add: subcls1_def2)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{fst (the (class P C))}" in finite_subset)
apply  auto
done
(*>*)
(*
lemma subcls_is_class: "(C,D) ∈ (subcls1 P)+ ⟹ is_class P C"
apply (unfold is_class_def)
apply(erule trancl_trans_induct)
apply (auto dest!: subcls1D)
done

lemma subcls_is_class: "P ⊢ C ≼* D ⟹ is_class P D ⟶ is_class P C"
apply (unfold is_class_def)
apply (erule rtrancl_induct)
apply  (drule_tac [2] subcls1D)
apply  auto
done
*)


subsection‹The subtype relations›

inductive
  widen   :: "'m prog  ty  ty  bool" ("_  _  _"   [71,71,71] 70)
  for P :: "'m prog"
where
  widen_refl[iff]: "P  T  T"
| widen_subcls: "P  C * D    P  Class C  Class D"
| widen_null[iff]: "P  NT  Class C"

abbreviation
  widens :: "'m prog  ty list  ty list  bool"
    ("_  _ [≤] _" [71,71,71] 70) where
  "widens P Ts Ts'  list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P  T  Void) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  T  Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  T  Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  Void  T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  Boolean  T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P  Integer  T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)


lemma Class_widen: "P  Class C  T    D. T = Class D"
(*<*)
apply (ind_cases "P  Class C  T")
apply auto
done
(*>*)

lemma [iff]: "(P  T  NT) = (T = NT)"
(*<*)
apply(cases T)
apply(auto dest:Class_widen)
done
(*>*)

lemma Class_widen_Class [iff]: "(P  Class C  Class D) = (P  C * D)"
(*<*)
apply (rule iffI)
apply (ind_cases "P  Class C  Class D")
apply (auto elim: widen_subcls)
done
(*>*)

lemma widen_Class: "(P  T  Class C) = (T = NT  (D. T = Class D  P  D * C))"
(*<*)by(induct T, auto)(*>*)


lemma widen_trans[trans]: "P  S  U; P  U  T  P  S  T"
(*<*)
proof -
  assume "PS  U" thus "T. P  U  T  P  S  T"
  proof induct
    case (widen_refl T T') thus "P  T  T'" .
  next
    case (widen_subcls C D T)
    then obtain E where "T = Class E" by (blast dest: Class_widen)
    with widen_subcls show "P  Class C  T" by (auto elim: rtrancl_trans)
  next
    case (widen_null C RT)
    then obtain D where "RT = Class D" by (blast dest: Class_widen)
    thus "P  NT  RT" by auto
  qed
qed
(*>*)

lemma widens_trans [trans]: "P  Ss [≤] Ts; P  Ts [≤] Us  P  Ss [≤] Us"
(*<*)by (rule list_all2_trans, rule widen_trans)(*>*)


(*<*)
lemmas widens_refl [iff] = list_all2_refl [of "widen P", OF widen_refl] for P
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
(*>*)


subsection‹Method lookup›

inductive
  Methods :: "['m prog, cname, mname  (ty list × ty × 'm) × cname]  bool"
                    ("_  _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where
  sees_methods_Object:
 " class P Object = Some(D,fs,ms); Mm = map_option (λm. (m,Object))  map_of ms 
   P  Object sees_methods Mm"
| sees_methods_rec:
 " class P C = Some(D,fs,ms); C  Object; P  D sees_methods Mm;
    Mm' = Mm ++ (map_option (λm. (m,C))  map_of ms) 
   P  C sees_methods Mm'"

lemma sees_methods_fun:
assumes 1: "P  C sees_methods Mm"
shows "Mm'. P  C sees_methods Mm'  Mm' = Mm"
 (*<*)
using 1
proof induct
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C  Object" and Dmethods: "P  D sees_methods Dres"
   and IH: "Dres'. P  D sees_methods Dres'  Dres' = Dres"
   and Cres: "Cres = Dres ++ (map_option (λm. (m,C))  map_of ms)"
   and Cmethods': "P  C sees_methods Cres'" by fact+
  from Cmethods' notObj "class" obtain Dres'
    where Dmethods': "P  D sees_methods Dres'"
     and Cres': "Cres' = Dres' ++ (map_option (λm. (m,C))  map_of ms)"
    by(auto elim: Methods.cases)
  from Cres Cres' IH[OF Dmethods'] show "Cres' = Cres" by simp
next
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
qed
(*>*)

lemma visible_methods_exist:
  "P  C sees_methods Mm  Mm M = Some(m,D) 
   (D' fs ms. class P D = Some(D',fs,ms)  map_of ms M = Some m)"
 (*<*)by(induct rule:Methods.induct) auto(*>*)

lemma sees_methods_decl_above:
assumes Csees: "P  C sees_methods Mm"
shows "Mm M = Some(m,D)  P  C * D"
 (*<*)
using Csees
proof induct
  case sees_methods_Object thus ?case by auto
next
  case sees_methods_rec thus ?case
    by(fastforce simp:map_option_case split:option.splits
                elim:converse_rtrancl_into_rtrancl[OF subcls1I])
qed
(*>*)

lemma sees_methods_idemp:
assumes Cmethods: "P  C sees_methods Mm"
shows "m D. Mm M = Some(m,D) 
              Mm'. (P  D sees_methods Mm')  Mm' M = Some(m,D)"
(*<*)
using Cmethods
proof induct
  case sees_methods_Object thus ?case
    by(fastforce dest: Methods.sees_methods_Object)
next
  case sees_methods_rec thus ?case
    by(fastforce split:option.splits dest: Methods.sees_methods_rec)
qed
(*>*)

(*FIXME something wrong with induct: need to attache [consumes 1]
directly to proof of thm, declare does not work. *)

lemma sees_methods_decl_mono:
assumes sub: "P  C' * C"
shows "P  C sees_methods Mm 
       Mm' Mm2. P  C' sees_methods Mm'  Mm' = Mm ++ Mm2 
                 (M m D. Mm2 M = Some(m,D)  P  D * C)"
(*<*)
      (is "_  Mm' Mm2. ?Q C' C Mm' Mm2")
using sub
proof (induct rule:converse_rtrancl_induct)
  assume "P  C sees_methods Mm"
  hence "?Q C C Mm Map.empty" by simp
  thus "Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  fix C'' C'
  assume sub1: "P  C'' 1 C'" and sub: "P  C' * C"
  and IH: "P  C sees_methods Mm 
           Mm' Mm2. P  C' sees_methods Mm' 
                Mm' = Mm ++ Mm2  (M m D. Mm2 M = Some(m,D)  P  D * C)"
  and Csees: "P  C sees_methods Mm"
  from IH[OF Csees] obtain Mm' Mm2 where C'sees: "P  C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC:"M m D. Mm2 M = Some(m,D)  P  D * C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C''  Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (λm. (m,C''))  map_of ms"
  have "P  C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtrancl_into_rtrancl[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed
(*>*)


definition Method :: "'m prog  cname  mname  ty list  ty  'm  cname  bool"
            ("_  _ sees _: __ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P  C sees M: TsT = m in D  
  Mm. P  C sees_methods Mm  Mm M = Some((Ts,T,m),D)"

definition has_method :: "'m prog  cname  mname  bool" ("_  _ has _" [51,0,51] 50)
where
  "P  C has M  Ts T m D. P  C sees M:TsT = m in D"

lemma sees_method_fun:
  "P  C sees M:TST = m in D; P  C sees M:TS'T' = m' in D' 
    TS' = TS  T' = T  m' = m  D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P  C sees M:TsT = m in D  P  C * D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P  C sees M:TsT = m in D 
  D' fs ms. class P D = Some(D',fs,ms)  map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)


lemma sees_method_idemp:
  "P  C sees M:TsT=m in D  P  D sees M:TsT=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
  " P  C' * C; P  C sees M:TsT = m in D;
     P  C' sees M:Ts'T' = m' in D'   P  D' * D"
 (*<*)
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtrancl_trans)
done
(*>*)

lemma sees_method_is_class:
  " P  C sees M:TsT = m in D   is_class P C"
(*<*)by (auto simp add: is_class_def Method_def elim: Methods.induct)(*>*)


subsection‹Field lookup›

inductive
  Fields :: "['m prog, cname, ((vname × cname) × ty) list]  bool"
                  ("_  _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where
  has_fields_rec:
  " class P C = Some(D,fs,ms); C  Object; P  D has_fields FDTs;
     FDTs' = map (λ(F,T). ((F,C),T)) fs @ FDTs 
    P  C has_fields FDTs'"
| has_fields_Object:
  " class P Object = Some(D,fs,ms); FDTs = map (λ(F,T). ((F,Object),T)) fs 
    P  Object has_fields FDTs"

lemma has_fields_fun:
assumes 1: "P  C has_fields FDTs"
shows "FDTs'. P  C has_fields FDTs'  FDTs' = FDTs"
 (*<*)
using 1
proof induct
  case (has_fields_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C  Object" and DFields: "P  D has_fields Dres"
   and IH: "Dres'. P  D has_fields Dres'  Dres' = Dres"
   and Cres: "Cres = map (λ(F,T). ((F,C),T)) fs @ Dres"
   and CFields': "P  C has_fields Cres'" by fact+
  from CFields' notObj "class" obtain Dres'
    where DFields': "P  D has_fields Dres'"
     and Cres': "Cres' = map (λ(F,T). ((F,C),T)) fs @ Dres'"
    by(auto elim: Fields.cases)
  from Cres Cres' IH[OF DFields'] show "Cres' = Cres" by simp
next
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
qed
(*>*)

lemma all_fields_in_has_fields:
assumes sub: "P  C has_fields FDTs"
shows " P  C * D; class P D = Some(D',fs,ms); (F,T)  set fs 
        ((F,D),T)  set FDTs"
(*<*)
using sub apply(induct)
 apply(simp add:image_def)
 apply(erule converse_rtranclE)
  apply(force)
 apply(drule subcls1D)
 apply fastforce
apply(force simp:image_def)
done
(*>*)


lemma has_fields_decl_above:
assumes fields: "P  C has_fields FDTs"
shows "((F,D),T)  set FDTs  P  C * D"
(*<*)
using fields apply(induct)
 prefer 2 apply fastforce
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
apply simp
apply(blast dest:subcls1I converse_rtrancl_into_rtrancl)
done
(*>*)


lemma subcls_notin_has_fields:
assumes fields: "P  C has_fields FDTs"
shows "((F,D),T)  set FDTs  (D,C)  (subcls1 P)+"
(*<*)
using fields apply(induct)
 prefer 2 apply(fastforce dest: tranclD)
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
 apply(drule tranclD)
 apply clarify
 apply(frule subcls1D)
 apply(fastforce dest:all_fields_in_has_fields)
apply simp
apply(blast dest:subcls1I trancl_into_trancl)
done
(*>*)


lemma has_fields_mono_lem:
assumes sub: "P  D * C"
shows "P  C has_fields FDTs
          pre. P  D has_fields pre@FDTs  dom(map_of pre)  dom(map_of FDTs) = {}"
(*<*)
using sub apply(induct rule:converse_rtrancl_induct)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(D',C) : (subcls1 P)^+")
 prefer 2 apply(erule (1) rtrancl_into_trancl2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
 apply(rule refl)
apply(rule_tac x = "map (λ(F,T). ((F,D'),T)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done
(*>*)

(* FIXME why is Field not displayed correctly? TypeRel qualifier seems to confuse printer*)
definition has_field :: "'m prog  cname  vname  ty  cname  bool"
                   ("_  _ has _:_ in _" [51,51,51,51,51] 50)
where
  "P  C has F:T in D  
  FDTs. P  C has_fields FDTs  map_of FDTs (F,D) = Some T"

lemma has_field_mono:
  " P  C has F:T in D; P  C' * C   P  C' has F:T in D"
(*<*)
apply(clarsimp simp:has_field_def)
apply(drule (1) has_fields_mono_lem)
apply(fastforce simp: map_add_def split:option.splits)
done
(*>*)


definition sees_field :: "'m prog  cname  vname  ty  cname  bool"
                  ("_  _ sees _:_ in _" [51,51,51,51,51] 50)
where
  "P  C sees F:T in D  
  FDTs. P  C has_fields FDTs 
            map_of (map (λ((F,D),T). (F,(D,T))) FDTs) F = Some(D,T)"

lemma map_of_remap_SomeD:
  "map_of (map (λ((k,k'),x). (k,(k',x))) t) k = Some (k',x)  map_of t (k, k') = Some x"
(*<*)by (induct t) (auto simp:fun_upd_apply split: if_split_asm)(*>*)


lemma has_visible_field:
  "P  C sees F:T in D  P  C has F:T in D"
(*<*)by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)(*>*)


lemma sees_field_fun:
  "P  C sees F:T in D; P  C sees F:T' in D'  T' = T  D' = D"
(*<*)by(fastforce simp:sees_field_def dest:has_fields_fun)(*>*)


lemma sees_field_decl_above:
  "P  C sees F:T in D  P  C * D"
(*<*)
apply(auto simp:sees_field_def)
apply(blast  intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)
done
(*>*)

(* FIXME ugly *)  
lemma sees_field_idemp:
  "P  C sees F:T in D  P  D sees F:T in D"
(*<*)
  apply (unfold sees_field_def)
  apply clarsimp
  apply (rule_tac P = "map_of xs F = y" for xs y in mp)
   prefer 2 
   apply assumption 
  apply (thin_tac "map_of xs F = y" for xs y)
  apply (erule Fields.induct)
   apply clarsimp
   apply (frule map_of_SomeD)
   apply clarsimp
   apply (fastforce intro: has_fields_rec)
  apply clarsimp
  apply (frule map_of_SomeD)
  apply clarsimp
  apply (fastforce intro: has_fields_Object)
  done
(*>*)

subsection "Functional lookup"

definition "method" :: "'m prog  cname  mname  cname × ty list × ty × 'm"
where
  "method P C M    THE (D,Ts,T,m). P  C sees M:Ts  T = m in D"

definition field  :: "'m prog  cname  vname  cname × ty"
where
  "field P C F    THE (D,T). P  C sees F:T in D"
                                                        
definition fields :: "'m prog  cname  ((vname × cname) × ty) list" 
where
  "fields P C    THE FDTs. P  C has_fields FDTs"                

lemma fields_def2 [simp]: "P  C has_fields FDTs  fields P C = FDTs"
(*<*)by (unfold fields_def) (auto dest: has_fields_fun)(*>*)

lemma field_def2 [simp]: "P  C sees F:T in D  field P C F = (D,T)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P  C sees M: TsT = m in D  method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

subsection "Code generator setup"

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
  subcls1p 
.
declare subcls1_def [code_pred_def]

code_pred 
  (modes: i ⇒ i × o ⇒ bool, i ⇒ i × i ⇒ bool)
  [inductify]
  subcls1 
.
definition subcls' where "subcls' G = (subcls1p G)^**"
code_pred
  (modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 G)^* = {(C, D). subcls' G C D}"
  by (simp add: subcls'_def subcls1_def rtrancl_def)

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ bool)
  widen 
.

code_pred 
  (modes: i ⇒ i ⇒ o ⇒ bool)
  Fields
.

lemma has_field_code [code_pred_intro]:
  " P  C has_fields FDTs; map_of FDTs (F, D) = T 
   P  C has F:T in D"
by(auto simp add: has_field_def)

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
  has_field
by(auto simp add: has_field_def)

lemma sees_field_code [code_pred_intro]:
  " P  C has_fields FDTs; map_of (map (λ((F, D), T). (F, D, T)) FDTs) F = (D, T) 
   P  C sees F:T in D"
by(auto simp add: sees_field_def)

code_pred 
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ i ⇒ bool, 
          i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
  sees_field
by(auto simp add: sees_field_def)

code_pred
  (modes: i ⇒ i ⇒ o ⇒ bool)
  Methods 
.

lemma Method_code [code_pred_intro]:
  " P  C sees_methods Mm; Mm M = ((Ts, T, m), D) 
   P  C sees M: TsT = m in D"
by(auto simp add: Method_def)

code_pred
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ o ⇒ bool,
          i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
  Method
by(auto simp add: Method_def)

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (λ(Ts, T, m, D). P  C sees M:TsT=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M = 
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (λ(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (λFDTs. P  C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

lemma eval_sees_field_i_i_i_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o P C F) = (λ(T, D). P  C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_oI elim: sees_field_i_i_i_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_i P C F D) = (λT. P  C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o P C F) (λ(T, D). Predicate.single (D, T)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

(*<*)
end
(*>*)

Theory Value

(*  Title:      Jinja/Common/Value.thy
    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Jinja Values›

theory Value imports TypeRel begin

type_synonym addr = nat

datatype val
  = Unit        ― ‹dummy result value of void expressions›
  | Null        ― ‹null reference›
  | Bool bool   ― ‹Boolean value›
  | Intg int    ― ‹integer value› 
  | Addr addr   ― ‹addresses of objects in the heap›

primrec the_Intg :: "val  int" where
  "the_Intg (Intg i) = i"

primrec the_Addr :: "val  addr" where
  "the_Addr (Addr a) = a"

primrec default_val :: "ty  val"   ― ‹default value for all types› where
  "default_val Void      = Unit"
| "default_val Boolean   = Bool False"
| "default_val Integer   = Intg 0"
| "default_val NT        = Null"
| "default_val (Class C) = Null"

end

Theory Objects

(*  Title:      HOL/MicroJava/J/State.thy

    Author:     David von Oheimb
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Objects and the Heap›

theory Objects imports TypeRel Value begin

subsection‹Objects›

type_synonym
  fields = "vname × cname  val"  ― ‹field name, defining class, value›
type_synonym
  obj = "cname × fields"    ― ‹class instance with class name and fields›

definition obj_ty  :: "obj  ty"
where
  "obj_ty obj    Class (fst obj)"

definition init_fields :: "((vname × cname) × ty) list  fields"
where
  "init_fields    map_of  map (λ(F,T). (F,default_val T))"
  
  ― ‹a new, blank object with default values in all fields:›
definition blank :: "'m prog  cname  obj"
where
  "blank P C    (C,init_fields (fields P C))" 

lemma [simp]: "obj_ty (C,fs) = Class C"
(*<*)by (simp add: obj_ty_def)(*>*)

subsection‹Heap›

type_synonym heap  = "addr  obj"

abbreviation
  cname_of :: "heap  addr  cname" where
  "cname_of hp a == fst (the (hp a))"

definition new_Addr  :: "heap  addr option"
where
  "new_Addr h    if a. h a = None then Some(LEAST a. h a = None) else None"

definition cast_ok :: "'m prog  cname  heap  val  bool"
where
  "cast_ok P C h v    v = Null  P  cname_of h (the_Addr v) * C"

definition hext :: "heap  heap  bool" ("_  _" [51,51] 50)
where
  "h  h'    a C fs. h a = Some(C,fs)  (fs'. h' a = Some(C,fs'))"

primrec typeof_h :: "heap  val  ty option"  ("typeof⇘_")
where
  "typeofh  Unit    = Some Void"
| "typeofh  Null    = Some NT"
| "typeofh (Bool b) = Some Boolean"
| "typeofh (Intg i) = Some Integer"
| "typeofh (Addr a) = (case h a of None  None | Some(C,fs)  Some(Class C))"

lemma new_Addr_SomeD:
  "new_Addr h = Some a  h a = None"
 (*<*)by(fastforce simp add:new_Addr_def split:if_splits intro:LeastI)(*>*)

lemma [simp]: "(typeofh v = Some Boolean) = (b. v = Bool b)"
 (*<*)by(induct v) auto(*>*)

lemma [simp]: "(typeofh v = Some Integer) = (i. v = Intg i)"
(*<*)by(cases v) auto(*>*)

lemma [simp]: "(typeofh v = Some NT) = (v = Null)"
 (*<*)by(cases v) auto(*>*)

lemma [simp]: "(typeofh v = Some(Class C)) = (a fs. v = Addr a  h a = Some(C,fs))"
 (*<*)by(cases v) auto(*>*)

lemma [simp]: "h a = Some(C,fs)  typeof(h(a(C,fs'))) v = typeofh v"
 (*<*)by(induct v) (auto simp:fun_upd_apply)(*>*)

text‹For literal values the first parameter of @{term typeof} can be
set to @{term Map.empty} because they do not contain addresses:›

abbreviation
  typeof :: "val  ty option" where
  "typeof v == typeof_h Map.empty v"

lemma typeof_lit_typeof:
  "typeof v = Some T  typeofh v = Some T"
 (*<*)by(cases v) auto(*>*)

lemma typeof_lit_is_type: 
  "typeof v = Some T  is_type P T"
 (*<*)by (induct v) (auto simp:is_type_def)(*>*)


subsection ‹Heap extension ⊴›

lemma hextI: "a C fs. h a = Some(C,fs)  (fs'. h' a = Some(C,fs'))  h  h'"
(*<*)
apply (unfold hext_def)
apply auto
done
(*>*)

lemma hext_objD: " h  h'; h a = Some(C,fs)   fs'. h' a = Some(C,fs')"
(*<*)
apply (unfold hext_def)
apply (force)
done
(*>*)

lemma hext_refl [iff]: "h  h"
(*<*)
apply (rule hextI)
apply (fast)
done
(*>*)

lemma hext_new [simp]: "h a = None  h  h(ax)"
(*<*)
apply (rule hextI)
apply (auto simp:fun_upd_apply)
done
(*>*)

lemma hext_trans: " h  h'; h'  h''   h  h''"
(*<*)
apply (rule hextI)
apply (fast dest: hext_objD)
done
(*>*)

lemma hext_upd_obj: "h a = Some (C,fs)  h  h(a(C,fs'))"
(*<*)
apply (rule hextI)
apply (auto simp:fun_upd_apply)
done
(*>*)

lemma hext_typeof_mono: " h  h'; typeofh v = Some T   typeofh' v = Some T"
(*<*)
apply(cases v)
    apply simp
   apply simp
  apply simp
 apply simp
apply(fastforce simp:hext_def)
done
(*>*)

text ‹Code generator setup for @{term "new_Addr"}

definition gen_new_Addr :: "heap  addr  addr option"
where "gen_new_Addr h n  if a. a  n  h a = None then Some(LEAST a. a  n  h a = None) else None"

lemma new_Addr_code_code [code]:
  "new_Addr h = gen_new_Addr h 0"
by(simp add: new_Addr_def gen_new_Addr_def split del: if_split cong: if_cong)

lemma gen_new_Addr_code [code]:
  "gen_new_Addr h n = (if h n = None then Some n else gen_new_Addr h (Suc n))"
apply(simp add: gen_new_Addr_def)
apply(rule impI)
apply(rule conjI)
 apply safe[1]
  apply(fastforce intro: Least_equality)
 apply(rule arg_cong[where f=Least])
 apply(rule ext)
 apply(case_tac "n = ac")
  apply simp
 apply(auto)[1]
apply clarify
apply(subgoal_tac "a = n")
 apply simp
 apply(rule Least_equality)
 apply auto[2]
apply(rule ccontr)
apply(erule_tac x="a" in allE)
apply simp
done

end

Theory Exceptions

(*  Title:      HOL/MicroJava/J/Exceptions.thy

    Author:     Gerwin Klein, Martin Strecker
    Copyright   2002 Technische Universitaet Muenchen
*)

section ‹Exceptions›

theory Exceptions imports Objects begin

definition NullPointer :: cname
where
  "NullPointer  ''NullPointer''"

definition ClassCast :: cname
where
  "ClassCast  ''ClassCast''"

definition OutOfMemory :: cname
where
  "OutOfMemory  ''OutOfMemory''"

definition sys_xcpts :: "cname set"
where
  "sys_xcpts    {NullPointer, ClassCast, OutOfMemory}"

definition addr_of_sys_xcpt :: "cname  addr"
where
  "addr_of_sys_xcpt s  if s = NullPointer then 0 else
                        if s = ClassCast then 1 else
                        if s = OutOfMemory then 2 else undefined"

definition start_heap :: "'c prog  heap"
where
  "start_heap G  Map.empty (addr_of_sys_xcpt NullPointer  blank G NullPointer)
                        (addr_of_sys_xcpt ClassCast  blank G ClassCast)
                        (addr_of_sys_xcpt OutOfMemory  blank G OutOfMemory)"

definition preallocated :: "heap  bool"
where
  "preallocated h  C  sys_xcpts. fs. h(addr_of_sys_xcpt C) = Some (C,fs)"


subsection "System exceptions"

lemma [simp]: "NullPointer  sys_xcpts  OutOfMemory  sys_xcpts  ClassCast  sys_xcpts"
(*<*)by(simp add: sys_xcpts_def)(*>*)


lemma sys_xcpts_cases [consumes 1, cases set]:
  " C  sys_xcpts; P NullPointer; P OutOfMemory; P ClassCast  P C"
(*<*)by (auto simp add: sys_xcpts_def)(*>*)


subsection "@{term preallocated}"

lemma preallocated_dom [simp]: 
  " preallocated h; C  sys_xcpts   addr_of_sys_xcpt C  dom h"
(*<*)by (fastforce simp:preallocated_def dom_def)(*>*)


lemma preallocatedD:
  " preallocated h; C  sys_xcpts   fs. h(addr_of_sys_xcpt C) = Some (C, fs)"
(*<*)by(auto simp add: preallocated_def sys_xcpts_def)(*>*)


lemma preallocatedE [elim?]:
  " preallocated h;  C  sys_xcpts; fs. h(addr_of_sys_xcpt C) = Some(C,fs)  P h C
   P h C"
(*<*)by (fast dest: preallocatedD)(*>*)


lemma cname_of_xcp [simp]:
  " preallocated h; C  sys_xcpts   cname_of h (addr_of_sys_xcpt C) = C"
(*<*)by (auto elim: preallocatedE)(*>*)


lemma typeof_ClassCast [simp]:
  "preallocated h  typeofh (Addr(addr_of_sys_xcpt ClassCast)) = Some(Class ClassCast)" 
(*<*)by (auto elim: preallocatedE)(*>*)


lemma typeof_OutOfMemory [simp]:
  "preallocated h  typeofh (Addr(addr_of_sys_xcpt OutOfMemory)) = Some(Class OutOfMemory)" 
(*<*)by (auto elim: preallocatedE)(*>*)


lemma typeof_NullPointer [simp]:
  "preallocated h  typeofh (Addr(addr_of_sys_xcpt NullPointer)) = Some(Class NullPointer)" 
(*<*)by (auto elim: preallocatedE)(*>*)


lemma preallocated_hext:
  " preallocated h; h  h'   preallocated h'"
(*<*)by (simp add: preallocated_def hext_def)(*>*)

(*<*)
lemmas preallocated_upd_obj = preallocated_hext [OF _ hext_upd_obj]
lemmas preallocated_new  = preallocated_hext [OF _ hext_new]
(*>*)


lemma preallocated_start:
  "preallocated (start_heap P)"
(*<*)by (auto simp add: start_heap_def blank_def sys_xcpts_def fun_upd_apply
                     addr_of_sys_xcpt_def preallocated_def)(*>*)


end

Theory Expr

(*  Title:      Jinja/J/Expr.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Expressions›

theory Expr
imports "../Common/Exceptions"
begin

datatype bop = Eq | Add     ― ‹names of binary operations›

datatype 'a exp
  = new cname      ― ‹class instance creation›
  | Cast cname "('a exp)"      ― ‹type cast›
  | Val val      ― ‹value›
  | BinOp "('a exp)" bop "('a exp)"     ("_ «_» _" [80,0,81] 80)      ― ‹binary operation›
  | Var 'a                                               ― ‹local variable (incl. parameter)›
  | LAss 'a "('a exp)"     ("_:=_" [90,90]90)                    ― ‹local assignment›
  | FAcc "('a exp)" vname cname     ("__{_}" [10,90,99]90)      ― ‹field access›
  | FAss "('a exp)" vname cname "('a exp)"     ("__{_} := _" [10,90,99,90]90)      ― ‹field assignment›
  | Call "('a exp)" mname "('a exp list)"     ("__'(_')" [90,99,0] 90)            ― ‹method call›
  | Block 'a ty "('a exp)"     ("'{_:_; _}")
  | Seq "('a exp)" "('a exp)"     ("_;;/ _"             [61,60]60)
  | Cond "('a exp)" "('a exp)" "('a exp)"     ("if '(_') _/ else _" [80,79,79]70)
  | While "('a exp)" "('a exp)"     ("while '(_') _"     [80,79]70)
  | throw "('a exp)"
  | TryCatch "('a exp)" cname 'a "('a exp)"     ("try _/ catch'(_ _') _"  [0,99,80,79] 70)

type_synonym
  expr = "vname exp"            ― ‹Jinja expression›
type_synonym
  J_mb = "vname list × expr"    ― ‹Jinja method body: parameter names and expression›
type_synonym
  J_prog = "J_mb prog"          ― ‹Jinja program›

text‹The semantics of binary operators:›

fun binop :: "bop × val × val  val option" where
  "binop(Eq,v1,v2) = Some(Bool (v1 = v2))"
| "binop(Add,Intg i1,Intg i2) = Some(Intg(i1+i2))"
| "binop(bop,v1,v2) = None"

lemma [simp]:
  "(binop(Add,v1,v2) = Some v) = (i1 i2. v1 = Intg i1  v2 = Intg i2  v = Intg(i1+i2))"
(*<*)
apply(cases v1)
apply auto
apply(cases v2)
apply auto
done
(*>*)


subsection "Syntactic sugar"

abbreviation (input)
  InitBlock:: "'a  ty  'a exp  'a exp  'a exp"   ("(1'{_:_ := _;/ _})") where
  "InitBlock V T e1 e2 == {V:T; V := e1;; e2}"

abbreviation unit where "unit == Val Unit"
abbreviation null where "null == Val Null"
abbreviation "addr a == Val(Addr a)"
abbreviation "true == Val(Bool True)"
abbreviation "false == Val(Bool False)"

abbreviation
  Throw :: "addr  'a exp" where
  "Throw a == throw(Val(Addr a))"

abbreviation
  THROW :: "cname  'a exp" where
  "THROW xc == Throw(addr_of_sys_xcpt xc)"


subsection‹Free Variables›

primrec fv :: "expr  vname set" and fvs :: "expr list  vname set" where
  "fv(new C) = {}"
| "fv(Cast C e) = fv e"
| "fv(Val v) = {}"
| "fv(e1 «bop» e2) = fv e1  fv e2"
| "fv(Var V) = {V}"
| "fv(LAss V e) = {V}  fv e"
| "fv(eF{D}) = fv e"
| "fv(e1F{D}:=e2) = fv e1  fv e2"
| "fv(eM(es)) = fv e  fvs es"
| "fv({V:T; e}) = fv e - {V}"
| "fv(e1;;e2) = fv e1  fv e2"
| "fv(if (b) e1 else e2) = fv b  fv e1  fv e2"
| "fv(while (b) e) = fv b  fv e"
| "fv(throw e) = fv e"
| "fv(try e1 catch(C V) e2) = fv e1  (fv e2 - {V})"
| "fvs([]) = {}"
| "fvs(e#es) = fv e  fvs es"

lemma [simp]: "fvs(es1 @ es2) = fvs es1  fvs es2"
(*<*)by (induct es1 type:list) auto(*>*)

lemma [simp]: "fvs(map Val vs) = {}"
(*<*)by (induct vs) auto(*>*)

end

Theory State

(*  Title:      Jinja/J/State.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Program State›

theory State imports "../Common/Exceptions" begin

type_synonym
  locals = "vname  val"      ― ‹local vars, incl. params and ``this''›
type_synonym
  state  = "heap × locals"

definition hp :: "state  heap"
where
  "hp    fst"
definition lcl :: "state  locals"
where
  "lcl    snd"

(*<*)
declare hp_def[simp] lcl_def[simp]
(*>*)
end

Theory BigStep

(*  Title:      Jinja/J/BigStep.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Big Step Semantics›

theory BigStep imports Expr State begin

inductive
  eval :: "J_prog  expr  state  expr  state  bool"
          ("_  ((1_,/_) / (1_,/_))" [51,0,0,0,0] 81)
  and evals :: "J_prog  expr list  state  expr list  state  bool"
           ("_  ((1_,/_) [⇒]/ (1_,/_))" [51,0,0,0,0] 81)
  for P :: J_prog
where

  New:
  " new_Addr h = Some a; P  C has_fields FDTs; h' = h(a(C,init_fields FDTs)) 
   P  new C,(h,l)  addr a,(h',l)"

| NewFail:
  "new_Addr h = None 
  P  new C, (h,l)  THROW OutOfMemory,(h,l)"

| Cast:
  " P  e,s0  addr a,(h,l); h a = Some(D,fs); P  D * C 
   P  Cast C e,s0  addr a,(h,l)"

| CastNull:
  "P  e,s0  null,s1 
  P  Cast C e,s0  null,s1"

| CastFail:
  " P  e,s0 addr a,(h,l); h a = Some(D,fs); ¬ P  D * C 
   P  Cast C e,s0  THROW ClassCast,(h,l)"

| CastThrow:
  "P  e,s0  throw e',s1 
  P  Cast C e,s0  throw e',s1"

| Val:
  "P  Val v,s  Val v,s"

| BinOp:
  " P  e1,s0  Val v1,s1; P  e2,s1  Val v2,s2; binop(bop,v1,v2) = Some v 
   P  e1 «bop» e2,s0Val v,s2"

| BinOpThrow1:
  "P  e1,s0  throw e,s1 
  P  e1 «bop» e2, s0  throw e,s1"

| BinOpThrow2:
  " P  e1,s0  Val v1,s1; P  e2,s1  throw e,s2 
   P  e1 «bop» e2,s0  throw e,s2"

| Var:
  "l V = Some v 
  P  Var V,(h,l)  Val v,(h,l)"

| LAss:
  " P  e,s0  Val v,(h,l); l' = l(Vv) 
   P  V:=e,s0  unit,(h,l')"

| LAssThrow:
  "P  e,s0  throw e',s1 
  P  V:=e,s0  throw e',s1"

| FAcc:
  " P  e,s0  addr a,(h,l); h a = Some(C,fs); fs(F,D) = Some v 
   P  eF{D},s0  Val v,(h,l)"

| FAccNull:
  "P  e,s0  null,s1 
  P  eF{D},s0  THROW NullPointer,s1"

| FAccThrow:
  "P  e,s0  throw e',s1 
  P  eF{D},s0  throw e',s1"

| FAss:
  " P  e1,s0  addr a,s1; P  e2,s1  Val v,(h2,l2);
     h2 a = Some(C,fs); fs' = fs((F,D)v); h2' = h2(a(C,fs')) 
   P  e1F{D}:=e2,s0  unit,(h2',l2)"

| FAssNull:
  " P  e1,s0  null,s1;  P  e2,s1  Val v,s2  
  P  e1F{D}:=e2,s0  THROW NullPointer,s2"

| FAssThrow1:
  "P  e1,s0  throw e',s1 
  P  e1F{D}:=e2,s0  throw e',s1"

| FAssThrow2:
  " P  e1,s0  Val v,s1; P  e2,s1  throw e',s2 
   P  e1F{D}:=e2,s0  throw e',s2"

| CallObjThrow:
  "P  e,s0  throw e',s1 
  P  eM(ps),s0  throw e',s1"

| CallParamsThrow:
  " P  e,s0  Val v,s1; P  es,s1 [⇒] map Val vs @ throw ex # es',s2 
    P  eM(es),s0  throw ex,s2"

| CallNull:
  " P  e,s0  null,s1;  P  ps,s1 [⇒] map Val vs,s2 
   P  eM(ps),s0  THROW NullPointer,s2"

| Call:
  " P  e,s0  addr a,s1;  P  ps,s1 [⇒] map Val vs,(h2,l2);
     h2 a = Some(C,fs);  P  C sees M:TsT = (pns,body) in D;
     length vs = length pns;  l2' = [thisAddr a, pns[↦]vs];
     P  body,(h2,l2')  e',(h3,l3) 
   P  eM(ps),s0  e',(h3,l2)"

| Block:
  "P  e0,(h0,l0(V:=None))  e1,(h1,l1) 
  P  {V:T; e0},(h0,l0)  e1,(h1,l1(V:=l0 V))"

| Seq:
  " P  e0,s0  Val v,s1; P  e1,s1  e2,s2 
   P  e0;;e1,s0  e2,s2"

| SeqThrow:
  "P  e0,s0  throw e,s1 
  P  e0;;e1,s0throw e,s1"

| CondT:
  " P  e,s0  true,s1; P  e1,s1  e',s2 
   P  if (e) e1 else e2,s0  e',s2"

| CondF:
  " P  e,s0  false,s1; P  e2,s1  e',s2 
   P  if (e) e1 else e2,s0  e',s2"

| CondThrow:
  "P  e,s0  throw e',s1 
  P  if (e) e1 else e2, s0  throw e',s1"

| WhileF:
  "P  e,s0  false,s1 
  P  while (e) c,s0  unit,s1"

| WhileT:
  " P  e,s0  true,s1; P  c,s1  Val v1,s2; P  while (e) c,s2  e3,s3 
   P  while (e) c,s0  e3,s3"

| WhileCondThrow:
  "P  e,s0   throw e',s1 
  P  while (e) c,s0  throw e',s1"

| WhileBodyThrow:
  " P  e,s0  true,s1; P  c,s1  throw e',s2
   P  while (e) c,s0  throw e',s2"

| Throw:
  "P  e,s0  addr a,s1 
  P  throw e,s0  Throw a,s1"

| ThrowNull:
  "P  e,s0  null,s1 
  P  throw e,s0  THROW NullPointer,s1"

| ThrowThrow:
  "P  e,s0  throw e',s1 
  P  throw e,s0  throw e',s1"

| Try:
  "P  e1,s0  Val v1,s1 
  P  try e1 catch(C V) e2,s0  Val v1,s1"

| TryCatch:
  " P  e1,s0  Throw a,(h1,l1);  h1 a = Some(D,fs);  P  D * C;
     P  e2,(h1,l1(VAddr a))  e2',(h2,l2) 
   P  try e1 catch(C V) e2,s0  e2',(h2,l2(V:=l1 V))"

| TryThrow:
  " P  e1,s0  Throw a,(h1,l1);  h1 a = Some(D,fs);  ¬ P  D * C 
   P  try e1 catch(C V) e2,s0  Throw a,(h1,l1)"

| Nil:
  "P  [],s [⇒] [],s"

| Cons:
  " P  e,s0  Val v,s1; P  es,s1 [⇒] es',s2 
   P  e#es,s0 [⇒] Val v # es',s2"

| ConsThrow:
  "P  e, s0  throw e', s1 
  P  e#es, s0 [⇒] throw e' # es, s1"

(*<*)
lemmas eval_evals_induct = eval_evals.induct [split_format (complete)]
  and eval_evals_inducts = eval_evals.inducts [split_format (complete)]

inductive_cases eval_cases [cases set]:
 "P  Cast C e,s  e',s'"
 "P  Val v,s  e',s'"
 "P  e1 «bop» e2,s  e',s'"
 "P  V:=e,s  e',s'"
 "P  eF{D},s  e',s'"
 "P  e1F{D}:=e2,s  e',s'"
 "P  eM{D}(es),s  e',s'"
 "P  {V:T;e1},s  e',s'"
 "P  e1;;e2,s  e',s'"
 "P  if (e) e1 else e2,s  e',s'"
 "P  while (b) c,s  e',s'"
 "P  throw e,s  e',s'"
 "P  try e1 catch(C V) e2,s  e',s'"
 
inductive_cases evals_cases [cases set]:
 "P  [],s [⇒] e',s'"
 "P  e#es,s [⇒] e',s'"
(*>*) 


subsection"Final expressions"

definition final :: "'a exp  bool"
where
  "final e    (v. e = Val v)  (a. e = Throw a)"

definition finals:: "'a exp list  bool"
where
  "finals es    (vs. es = map Val vs)  (vs a es'. es = map Val vs @ Throw a # es')"

lemma [simp]: "final(Val v)"
(*<*)by(simp add:final_def)(*>*)

lemma [simp]: "final(throw e) = (a. e = addr a)"
(*<*)by(simp add:final_def)(*>*)

lemma finalE: " final e;  v. e = Val v  R;  a. e = Throw a  R   R"
(*<*)by(auto simp:final_def)(*>*)

lemma [iff]: "finals []"
(*<*)by(simp add:finals_def)(*>*)

lemma [iff]: "finals (Val v # es) = finals es"
(*<*)
apply(clarsimp simp add: finals_def)
apply(rule iffI)
 apply(erule disjE)
  apply simp
 apply(rule disjI2)
 apply clarsimp
 apply(case_tac vs)
  apply simp
 apply fastforce
apply(erule disjE)
 apply clarsimp
apply(rule disjI2)
apply clarsimp
apply(rule_tac x = "v#vs" in exI)
apply simp
done
(*>*)

lemma finals_app_map[iff]: "finals (map Val vs @ es) = finals es"
(*<*)by(induct_tac vs, auto)(*>*)

lemma [iff]: "finals (map Val vs)"
(*<*)using finals_app_map[of vs "[]"]by(simp)(*>*)

lemma [iff]: "finals (throw e # es) = (a. e = addr a)"
(*<*)
apply(simp add:finals_def)
apply(rule iffI)
 apply clarsimp
 apply(case_tac vs)
  apply simp
 apply fastforce
apply clarsimp
apply(rule_tac x = "[]" in exI)
apply simp
done
(*>*)

lemma not_finals_ConsI: "¬ final e  ¬ finals(e#es)"
 (*<*)
apply(clarsimp simp add:finals_def final_def)
apply(case_tac vs)
apply auto
done
(*>*)


lemma eval_final: "P  e,s  e',s'  final e'"
 and evals_final: "P  es,s [⇒] es',s'  finals es'"
(*<*)by(induct rule:eval_evals.inducts, simp_all)(*>*)


lemma eval_lcl_incr: "P  e,(h0,l0)  e',(h1,l1)  dom l0  dom l1"
 and evals_lcl_incr: "P  es,(h0,l0) [⇒] es',(h1,l1)  dom l0  dom l1"
(*<*)
proof (induct rule: eval_evals_inducts)
  case BinOp show ?case by(rule subset_trans)(rule BinOp.hyps)+
next
  case Call thus ?case
    by(simp del: fun_upd_apply) 
next
  case Seq show ?case by(rule subset_trans)(rule Seq.hyps)+
next
  case CondT show ?case by(rule subset_trans)(rule CondT.hyps)+
next
  case CondF show ?case by(rule subset_trans)(rule CondF.hyps)+
next
  case WhileT thus ?case by(blast)
next
  case TryCatch thus ?case by(clarsimp simp:dom_def split:if_split_asm) blast
next
  case Cons show ?case by(rule subset_trans)(rule Cons.hyps)+
next
  case Block thus ?case by(auto simp del:fun_upd_apply)
qed auto
(*>*)

text‹Only used later, in the small to big translation, but is already a
good sanity check:›

lemma eval_finalId:  "final e  P  e,s  e,s"
(*<*)by (erule finalE) (iprover intro: eval_evals.intros)+(*>*)


lemma eval_finalsId:
assumes finals: "finals es" shows "P  es,s [⇒] es,s"
(*<*)
  using finals
proof (induct es type: list)
  case Nil show ?case by (rule eval_evals.intros)
next
  case (Cons e es)
  have hyp: "finals es  P  es,s [⇒] es,s"
   and finals: "finals (e # es)" by fact+
  show "P  e # es,s [⇒] e # es,s"
  proof cases
    assume "final e"
    thus ?thesis
    proof (cases rule: finalE)
      fix v assume e: "e = Val v"
      have "P  Val v,s  Val v,s" by (simp add: eval_finalId)
      moreover from finals e have "P  es,s [⇒] es,s" by(fast intro:hyp)
      ultimately have "P  Val v#es,s [⇒] Val v#es,s"
        by (rule eval_evals.intros)
      with e show ?thesis by simp
    next
      fix a assume e: "e = Throw a"
      have "P  Throw a,s  Throw a,s" by (simp add: eval_finalId)
      hence "P  Throw a#es,s [⇒] Throw a#es,s" by (rule eval_evals.intros)
      with e show ?thesis by simp
    qed
  next
    assume "¬ final e"
    with not_finals_ConsI finals have False by blast
    thus ?thesis ..
  qed
qed
(*>*)


theorem eval_hext: "P  e,(h,l)  e',(h',l')  h  h'"
and evals_hext:  "P  es,(h,l) [⇒] es',(h',l')  h  h'"
(*<*)
proof (induct rule: eval_evals_inducts)
  case New thus ?case
    by(fastforce intro!: hext_new intro:LeastI simp:new_Addr_def
                split:if_split_asm simp del:fun_upd_apply)
next
  case BinOp thus ?case by (fast elim!:hext_trans)
next
  case BinOpThrow2 thus ?case by(fast elim!: hext_trans)
next
  case FAss thus ?case
    by(auto simp:sym[THEN hext_upd_obj] simp del:fun_upd_apply
            elim!: hext_trans)
next
  case FAssNull thus ?case by (fast elim!:hext_trans)
next
  case FAssThrow2 thus ?case by (fast elim!:hext_trans)
next
  case CallParamsThrow thus ?case by(fast elim!: hext_trans)
next
  case CallNull thus ?case by(fast elim!: hext_trans)
next
  case Call thus ?case by(fast elim!: hext_trans)
next
  case Seq thus ?case by(fast elim!: hext_trans)
next
  case CondT thus ?case by(fast elim!: hext_trans)
next
  case CondF thus ?case by(fast elim!: hext_trans)
next
  case WhileT thus ?case by(fast elim!: hext_trans)
next
  case WhileBodyThrow thus ?case by (fast elim!: hext_trans)
next
  case TryCatch thus ?case  by(fast elim!: hext_trans)
next
  case Cons thus ?case by (fast intro: hext_trans)
qed auto
(*>*)


end

Theory SmallStep

(*  Title:      Jinja/J/SmallStep.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Small Step Semantics›

theory SmallStep
imports Expr State
begin

fun blocks :: "vname list * ty list * val list * expr  expr"
where
 "blocks(V#Vs, T#Ts, v#vs, e) = {V:T := Val v; blocks(Vs,Ts,vs,e)}"
|"blocks([],[],[],e) = e"

lemmas blocks_induct = blocks.induct[split_format (complete)]

lemma [simp]:
  " size vs = size Vs; size Ts = size Vs   fv(blocks(Vs,Ts,vs,e)) = fv e - set Vs"
(*<*)
by (induct rule:blocks_induct) auto
(*>*)


definition assigned :: "vname  expr  bool"
where
  "assigned V e    v e'. e = (V := Val v;; e')"

inductive_set
  red  :: "J_prog  ((expr × state) × (expr × state)) set"
  and reds  :: "J_prog  ((expr list × state) × (expr list × state)) set"
  and red' :: "J_prog  expr  state  expr  state  bool"
          ("_  ((1_,/_) / (1_,/_))" [51,0,0,0,0] 81)
  and reds' :: "J_prog  expr list  state  expr list  state  bool"
          ("_  ((1_,/_) [→]/ (1_,/_))" [51,0,0,0,0] 81)
  for P :: J_prog
where

  "P  e,s  e',s'  ((e,s), e',s')  red P"
| "P  es,s [→] es',s'  ((es,s), es',s')  reds P"

| RedNew:
  " new_Addr h = Some a; P  C has_fields FDTs; h' = h(a(C,init_fields FDTs)) 
   P  new C, (h,l)  addr a, (h',l)"

| RedNewFail:
  "new_Addr h = None 
  P  new C, (h,l)  THROW OutOfMemory, (h,l)"

| CastRed:
  "P  e,s  e',s' 
  P  Cast C e, s  Cast C e', s'"

| RedCastNull:
  "P  Cast C null, s  null,s"

| RedCast:
 " hp s a = Some(D,fs); P  D * C 
   P  Cast C (addr a), s  addr a, s"

| RedCastFail:
  " hp s a = Some(D,fs); ¬ P  D * C 
   P  Cast C (addr a), s  THROW ClassCast, s"

| BinOpRed1:
  "P  e,s  e',s' 
  P  e «bop» e2, s  e' «bop» e2, s'"

| BinOpRed2:
  "P  e,s  e',s' 
  P  (Val v1) «bop» e, s  (Val v1) «bop» e', s'"

| RedBinOp:
  "binop(bop,v1,v2) = Some v 
  P  (Val v1) «bop» (Val v2), s  Val v,s"

| RedVar:
  "lcl s V = Some v 
  P  Var V,s  Val v,s"

| LAssRed:
  "P  e,s  e',s' 
  P  V:=e,s  V:=e',s'"

| RedLAss:
  "P  V:=(Val v), (h,l)  unit, (h,l(Vv))"

| FAccRed:
  "P  e,s  e',s' 
  P  eF{D}, s  e'F{D}, s'"

| RedFAcc:
  " hp s a = Some(C,fs); fs(F,D) = Some v 
   P  (addr a)F{D}, s  Val v,s"

| RedFAccNull:
  "P  nullF{D}, s  THROW NullPointer, s"

| FAssRed1:
  "P  e,s  e',s' 
  P  eF{D}:=e2, s  e'F{D}:=e2, s'"

| FAssRed2:
  "P  e,s  e',s' 
  P  Val vF{D}:=e, s  Val vF{D}:=e', s'"

| RedFAss:
  "h a = Some(C,fs) 
  P  (addr a)F{D}:=(Val v), (h,l)  unit, (h(a  (C,fs((F,D)  v))),l)"

| RedFAssNull:
  "P  nullF{D}:=Val v, s  THROW NullPointer, s"

| CallObj:
  "P  e,s  e',s' 
  P  eM(es),s  e'M(es),s'"

| CallParams:
  "P  es,s [→] es',s' 
  P  (Val v)M(es),s  (Val v)M(es'),s'"

| RedCall:
  " hp s a = Some(C,fs); P  C sees M:TsT = (pns,body) in D; size vs = size pns; size Ts = size pns 
   P  (addr a)M(map Val vs), s  blocks(this#pns, Class D#Ts, Addr a#vs, body), s"

| RedCallNull:
  "P  nullM(map Val vs),s  THROW NullPointer,s"

| BlockRedNone:
  " P  e, (h,l(V:=None))  e', (h',l'); l' V = None; ¬ assigned V e 
   P  {V:T; e}, (h,l)  {V:T; e'}, (h',l'(V := l V))"

| BlockRedSome:
  " P  e, (h,l(V:=None))  e', (h',l'); l' V = Some v;¬ assigned V e 
   P  {V:T; e}, (h,l)  {V:T := Val v; e'}, (h',l'(V := l V))"

| InitBlockRed:
  " P  e, (h,l(Vv))  e', (h',l'); l' V = Some v' 
   P  {V:T := Val v; e}, (h,l)  {V:T := Val v'; e'}, (h',l'(V := l V))"

| RedBlock:
  "P  {V:T; Val u}, s  Val u, s"

| RedInitBlock:
  "P  {V:T := Val v; Val u}, s  Val u, s"

| SeqRed:
  "P  e,s  e',s' 
  P  e;;e2, s  e';;e2, s'"

| RedSeq:
  "P  (Val v);;e2, s  e2, s"

| CondRed:
  "P  e,s  e',s' 
  P  if (e) e1 else e2, s  if (e') e1 else e2, s'"

| RedCondT:
  "P  if (true) e1 else e2, s  e1, s"

| RedCondF:
  "P  if (false) e1 else e2, s  e2, s"

| RedWhile:
  "P  while(b) c, s  if(b) (c;;while(b) c) else unit, s"

| ThrowRed:
  "P  e,s  e',s' 
  P  throw e, s  throw e', s'"

| RedThrowNull:
  "P  throw null, s  THROW NullPointer, s"

| TryRed:
  "P  e,s  e',s' 
  P  try e catch(C V) e2, s  try e' catch(C V) e2, s'"

| RedTry:
  "P  try (Val v) catch(C V) e2, s  Val v, s"

| RedTryCatch:
  " hp s a = Some(D,fs); P  D * C 
   P  try (Throw a) catch(C V) e2, s  {V:Class C := addr a; e2}, s"

| RedTryFail:
  " hp s a = Some(D,fs); ¬ P  D * C 
   P  try (Throw a) catch(C V) e2, s  Throw a, s"

| ListRed1:
  "P  e,s  e',s' 
  P  e#es,s [→] e'#es,s'"

| ListRed2:
  "P  es,s [→] es',s' 
  P  Val v # es,s [→] Val v # es',s'"

― ‹Exception propagation›

| CastThrow: "P  Cast C (throw e), s  throw e, s"
| BinOpThrow1: "P  (throw e) «bop» e2, s  throw e, s"
| BinOpThrow2: "P  (Val v1) «bop» (throw e), s  throw e, s"
| LAssThrow: "P  V:=(throw e), s  throw e, s"
| FAccThrow: "P  (throw e)F{D}, s  throw e, s"
| FAssThrow1: "P  (throw e)F{D}:=e2, s  throw e,s"
| FAssThrow2: "P  Val vF{D}:=(throw e), s  throw e, s"
| CallThrowObj: "P  (throw e)M(es), s  throw e, s"
| CallThrowParams: " es = map Val vs @ throw e # es'   P  (Val v)M(es), s  throw e, s"
| BlockThrow: "P  {V:T; Throw a}, s  Throw a, s"
| InitBlockThrow: "P  {V:T := Val v; Throw a}, s  Throw a, s"
| SeqThrow: "P  (throw e);;e2, s  throw e, s"
| CondThrow: "P  if (throw e) e1 else e2, s  throw e, s"
| ThrowThrow: "P  throw(throw e), s  throw e, s"
(*<*)
lemmas red_reds_induct = red_reds.induct [split_format (complete)]
  and red_reds_inducts = red_reds.inducts [split_format (complete)]

inductive_cases [elim!]:
 "P  V:=e,s  e',s'"
 "P  e1;;e2,s  e',s'"
(*>*)

subsection‹The reflexive transitive closure›

abbreviation
  Step :: "J_prog  expr  state  expr  state  bool"
          ("_  ((1_,/_) →*/ (1_,/_))" [51,0,0,0,0] 81)
  where "P  e,s →* e',s'  ((e,s), e',s')  (red P)*"

abbreviation
  Steps :: "J_prog  expr list  state  expr list  state  bool"
          ("_  ((1_,/_) [→]*/ (1_,/_))" [51,0,0,0,0] 81)
  where "P  es,s [→]* es',s'  ((es,s), es',s')  (reds P)*"

lemma converse_rtrancl_induct_red[consumes 1]:
assumes "P  e,(h,l) →* e',(h',l')"
and "e h l. R e h l e h l"
and "e0 h0 l0 e1 h1 l1 e' h' l'.
        P  e0,(h0,l0)  e1,(h1,l1); R e1 h1 l1 e' h' l'   R e0 h0 l0 e' h' l'"
shows "R e h l e' h' l'"
(*<*)
proof -
  { fix s s'
    assume reds: "P  e,s →* e',s'"
       and base: "e s. R e (hp s) (lcl s) e (hp s) (lcl s)"
       and red1: "e0 s0 e1 s1 e' s'.
            P  e0,s0  e1,s1; R e1 (hp s1) (lcl s1) e' (hp s') (lcl s') 
            R e0 (hp s0) (lcl s0) e' (hp s') (lcl s')"
    from reds have "R e (hp s) (lcl s) e' (hp s') (lcl s')"
    proof (induct rule:converse_rtrancl_induct2)
      case refl show ?case by(rule base)
    next
      case (step e0 s0 e s)
      thus ?case by(blast intro:red1)
    qed
    }
  with assms show ?thesis by fastforce
qed
(*>*)


subsection‹Some easy lemmas›

lemma [iff]: "¬ P  [],s [→] es',s'"
(*<*)by(blast elim: reds.cases)(*>*)

lemma [iff]: "¬ P  Val v,s  e',s'"
(*<*)by(fastforce elim: red.cases)(*>*)

lemma [iff]: "¬ P  Throw a,s  e',s'"
(*<*)by(fastforce elim: red.cases)(*>*)


lemma red_hext_incr: "P  e,(h,l)  e',(h',l')   h  h'"
  and reds_hext_incr: "P  es,(h,l) [→] es',(h',l')   h  h'"
(*<*)
proof(induct rule:red_reds_inducts)
  case RedNew thus ?case
    by(fastforce dest:new_Addr_SomeD simp:hext_def split:if_splits)
next
  case RedFAss thus ?case by(simp add:hext_def split:if_splits)
qed simp_all
(*>*)


lemma red_lcl_incr: "P  e,(h0,l0)  e',(h1,l1)  dom l0  dom l1"
and "P  es,(h0,l0) [→] es',(h1,l1)  dom l0  dom l1"
(*<*)by(induct rule: red_reds_inducts)(auto simp del:fun_upd_apply)(*>*)


lemma red_lcl_add: "P  e,(h,l)  e',(h',l')  (l0. P  e,(h,l0++l)  e',(h',l0++l'))"
and "P  es,(h,l) [→] es',(h',l')  (l0. P  es,(h,l0++l) [→] es',(h',l0++l'))"
(*<*)
proof (induct rule:red_reds_inducts)
  case RedCast thus ?case by(fastforce intro:red_reds.intros)
next
  case RedCastFail thus ?case by(force intro:red_reds.intros)
next
  case RedFAcc thus ?case by(fastforce intro:red_reds.intros)
next
  case RedCall thus ?case by(fastforce intro:red_reds.intros)
next
  case (InitBlockRed e h l V v e' h' l' v' T l0)
  have IH: "l0. P  e,(h, l0 ++ l(V  v))  e',(h', l0 ++ l')"
    and l'V: "l' V = Some v'" by fact+
  from IH have IH': "P  e,(h, (l0 ++ l)(V  v))  e',(h', l0 ++ l')"
    by simp
  have "(l0 ++ l')(V := (l0 ++ l) V) = l0 ++ l'(V := l V)"
    by(rule ext)(simp add:map_add_def)
  with red_reds.InitBlockRed[OF IH'] l'V show ?case by(simp del:fun_upd_apply)
next
  case (BlockRedNone e h l V e' h' l' T l0)
  have IH: "l0. P  e,(h, l0 ++ l(V := None))  e',(h', l0 ++ l')"
    and l'V: "l' V = None" and unass: "¬ assigned V e" by fact+
  have "l0(V := None) ++ l(V := None) = (l0 ++ l)(V := None)"
    by(simp add:fun_eq_iff map_add_def)
  hence IH': "P  e,(h, (l0++l)(V := None))  e',(h', l0(V := None) ++ l')"
    using IH[of "l0(V := None)"] by simp
  have "(l0(V := None) ++ l')(V := (l0 ++ l) V) = l0 ++ l'(V := l V)"
    by(simp add:fun_eq_iff map_add_def)
  with red_reds.BlockRedNone[OF IH' _ unass] l'V show ?case
    by(simp add: map_add_def)
next
  case (BlockRedSome e h l V e' h' l' v T l0)
  have IH: "l0. P  e,(h, l0 ++ l(V := None))  e',(h', l0 ++ l')"
    and l'V: "l' V = Some v" and unass: "¬ assigned V e" by fact+
  have "l0(V := None) ++ l(V := None) = (l0 ++ l)(V := None)"
    by(simp add:fun_eq_iff map_add_def)
  hence IH': "P  e,(h, (l0++l)(V := None))  e',(h', l0(V := None) ++ l')"
    using IH[of "l0(V := None)"] by simp
  have "(l0(V := None) ++ l')(V := (l0 ++ l) V) = l0 ++ l'(V := l V)"
    by(simp add:fun_eq_iff map_add_def)
  with red_reds.BlockRedSome[OF IH' _ unass] l'V show ?case
    by(simp add:map_add_def)
next
  case RedTryCatch thus ?case by(fastforce intro:red_reds.intros)
next
  case RedTryFail thus ?case by(force intro!:red_reds.intros)
qed (simp_all add:red_reds.intros)
(*>*)


lemma Red_lcl_add:
assumes "P  e,(h,l) →* e',(h',l')" shows "P  e,(h,l0++l) →* e',(h',l0++l')"
(*<*)
using assms
proof(induct rule:converse_rtrancl_induct_red)
  case 1 thus ?case by simp
next
  case 2 thus ?case
    by (blast dest: red_lcl_add intro: converse_rtrancl_into_rtrancl)
qed
(*>*)


end

Theory SystemClasses

(*  Title:      HOL/MicroJava/J/SystemClasses.thy

    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

section ‹System Classes›

theory SystemClasses
imports Decl Exceptions
begin

text ‹
  This theory provides definitions for the Object› class,
  and the system exceptions.
›

definition ObjectC :: "'m cdecl"
where
  "ObjectC  (Object, (undefined,[],[]))"

definition NullPointerC :: "'m cdecl"
where
  "NullPointerC  (NullPointer, (Object,[],[]))"

definition ClassCastC :: "'m cdecl"
where
  "ClassCastC  (ClassCast, (Object,[],[]))"

definition OutOfMemoryC :: "'m cdecl"
where
  "OutOfMemoryC  (OutOfMemory, (Object,[],[]))"

definition SystemClasses :: "'m cdecl list"
where
  "SystemClasses  [ObjectC, NullPointerC, ClassCastC, OutOfMemoryC]"

end

Theory WellForm

(*  Title:      Jinja/J/WellForm.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Generic Well-formedness of programs›

theory WellForm imports TypeRel SystemClasses begin

text ‹\noindent This theory defines global well-formedness conditions
for programs but does not look inside method bodies.  Hence it works
for both Jinja and JVM programs. Well-typing of expressions is defined
elsewhere (in theory WellType›).

Because Jinja does not have method overloading, its policy for method
overriding is the classical one: \emph{covariant in the result type
but contravariant in the argument types.} This means the result type
of the overriding method becomes more specific, the argument types
become more general.
›

type_synonym 'm wf_mdecl_test = "'m prog  cname  'm mdecl  bool"

definition wf_fdecl :: "'m prog  fdecl  bool"
where
  "wf_fdecl P  λ(F,T). is_type P T"

definition wf_mdecl :: "'m wf_mdecl_test  'm wf_mdecl_test"
where
  "wf_mdecl wf_md P C  λ(M,Ts,T,mb).
  (Tset Ts. is_type P T)  is_type P T  wf_md P C (M,Ts,T,mb)"

definition wf_cdecl :: "'m wf_mdecl_test  'm prog  'm cdecl  bool"
where
  "wf_cdecl wf_md P    λ(C,(D,fs,ms)).
  (fset fs. wf_fdecl P f)   distinct_fst fs 
  (mset ms. wf_mdecl wf_md P C m)   distinct_fst ms 
  (C  Object 
   is_class P D  ¬ P  D * C 
   ((M,Ts,T,m)set ms.
      D' Ts' T' m'. P  D sees M:Ts'  T' = m' in D' 
                       P  Ts' [≤] Ts  P  T  T'))"

definition wf_syscls :: "'m prog  bool"
where
  "wf_syscls P    {Object}  sys_xcpts  set(map fst P)"

definition wf_prog :: "'m wf_mdecl_test  'm prog  bool"
where
  "wf_prog wf_md P    wf_syscls P  (c  set P. wf_cdecl wf_md P c)  distinct_fst P"


subsection‹Well-formedness lemmas›

lemma class_wf: 
  "class P C = Some c; wf_prog wf_md P  wf_cdecl wf_md P (C,c)"
(*<*)
apply (unfold wf_prog_def class_def)
apply (fast dest: map_of_SomeD)
done
(*>*)


lemma class_Object [simp]: 
  "wf_prog wf_md P  C fs ms. class P Object = Some (C,fs,ms)"
(*<*)
apply (unfold wf_prog_def wf_syscls_def class_def)
apply (auto simp: map_of_SomeI)
done
(*>*)


lemma is_class_Object [simp]:
  "wf_prog wf_md P  is_class P Object"
(*<*)by (simp add: is_class_def)(*>*)
(* Unused
lemma is_class_supclass:
assumes wf: "wf_prog wf_md P" and sub: "P ⊢ C ≼* D"
shows "is_class P C ⟹ is_class P D"
using sub apply(induct)
 apply assumption
apply(fastforce simp:wf_cdecl_def subcls1_def is_class_def
               dest:class_wf[OF _ wf])
done

This is NOT true because P ⊢ NT ≤ Class C for any Class C
lemma is_type_suptype: "⟦ wf_prog p P; is_type P T; P ⊢ T ≤ T' ⟧
 ⟹ is_type P T'"
*)

lemma is_class_xcpt:
  " C  sys_xcpts; wf_prog wf_md P   is_class P C"
(*<*)
  apply (simp add: wf_prog_def wf_syscls_def is_class_def class_def)
  apply (fastforce intro!: map_of_SomeI)
  done
(*>*)


lemma subcls1_wfD:
  " P  C 1 D; wf_prog wf_md P   D  C  (D,C)  (subcls1 P)+"
(*<*)
apply( frule r_into_trancl)
apply( drule subcls1D)
apply(clarify)
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def)
apply(force simp add: reflcl_trancl [THEN sym] simp del: reflcl_trancl)
done
(*>*)


lemma wf_cdecl_supD: 
  "wf_cdecl wf_md P (C,D,r); C  Object  is_class P D"
(*<*)by (auto simp: wf_cdecl_def)(*>*)


lemma subcls_asym:
  " wf_prog wf_md P; (C,D)  (subcls1 P)+   (D,C)  (subcls1 P)+"
(*<*)
apply(erule tranclE)
apply(fast dest!: subcls1_wfD )
apply(fast dest!: subcls1_wfD intro: trancl_trans)
done
(*>*)


lemma subcls_irrefl:
  " wf_prog wf_md P; (C,D)  (subcls1 P)+   C  D"
(*<*)
apply (erule trancl_trans_induct)
apply  (auto dest: subcls1_wfD subcls_asym)
done
(*>*)


lemma acyclic_subcls1:
  "wf_prog wf_md P  acyclic (subcls1 P)"
(*<*)
apply (unfold acyclic_def)
apply (fast dest: subcls_irrefl)
done
(*>*)


lemma wf_subcls1:
  "wf_prog wf_md P  wf ((subcls1 P)¯)"
(*<*)
apply (rule finite_acyclic_wf)
apply ( subst finite_converse)
apply ( rule finite_subcls1)
apply (subst acyclic_converse)
apply (erule acyclic_subcls1)
done
(*>*)


lemma single_valued_subcls1:
  "wf_prog wf_md G  single_valued (subcls1 G)"
(*<*)
by(auto simp:wf_prog_def distinct_fst_def single_valued_def dest!:subcls1D)
(*>*)


lemma subcls_induct: 
  " wf_prog wf_md P; C. D. (C,D)  (subcls1 P)+  Q D  Q C   Q C"
(*<*)
  (is "?A  PROP ?P  _")
proof -
  assume p: "PROP ?P"
  assume ?A thus ?thesis apply -
apply(drule wf_subcls1)
apply(drule wf_trancl)
apply(simp only: trancl_converse)
apply(erule_tac a = C in wf_induct)
apply(rule p)
apply(auto)
done
qed
(*>*)


lemma subcls1_induct_aux:
  " is_class P C; wf_prog wf_md P; Q Object;
    C D fs ms.
     C  Object; is_class P C; class P C = Some (D,fs,ms) 
      wf_cdecl wf_md P (C,D,fs,ms)  P  C 1 D  is_class P D  Q D  Q C 
   Q C"
(*<*)
  (is "?A  ?B  ?C  PROP ?P  _")
proof -
  assume p: "PROP ?P"
  assume ?A ?B ?C thus ?thesis apply -
apply(unfold is_class_def)
apply( rule impE)
prefer 2
apply(   assumption)
prefer 2
apply(  assumption)
apply( erule thin_rl)
apply( rule subcls_induct)
apply(  assumption)
apply( rule impI)
apply( case_tac "C = Object")
apply(  fast)
apply safe
apply( frule (1) class_wf)
apply( frule (1) wf_cdecl_supD)

apply( subgoal_tac "P  C 1 a")
apply( erule_tac [2] subcls1I)
apply(  rule p)
apply (unfold is_class_def)
apply auto
done
qed
(*>*)

(* FIXME can't we prove this one directly?? *)
lemma subcls1_induct [consumes 2, case_names Object Subcls]:
  " wf_prog wf_md P; is_class P C; Q Object;
    C D. C  Object; P  C 1 D; is_class P D; Q D  Q C 
   Q C"
(*<*)
  apply (erule subcls1_induct_aux, assumption, assumption)
  apply blast
  done
(*>*)


lemma subcls_C_Object:
  " is_class P C; wf_prog wf_md P   P  C * Object"
(*<*)
apply(erule (1) subcls1_induct)
 apply( fast)
apply(erule (1) converse_rtrancl_into_rtrancl)
done
(*>*)


lemma is_type_pTs:
assumes "wf_prog wf_md P" and "(C,S,fs,ms)  set P" and "(M,Ts,T,m)  set ms"
shows "set Ts  types P"
(*<*)
proof
  from assms have "wf_mdecl wf_md P C (M,Ts,T,m)" 
    by (unfold wf_prog_def wf_cdecl_def) auto  
  hence "t  set Ts. is_type P t" by (unfold wf_mdecl_def) auto
  moreover fix t assume "t  set Ts"
  ultimately have "is_type P t" by blast
  thus "t  types P" ..
qed
(*>*)


subsection‹Well-formedness and method lookup›

lemma sees_wf_mdecl:
  " wf_prog wf_md P; P  C sees M:TsT = m in D   wf_mdecl wf_md P D (M,Ts,T,m)"
(*<*)
apply(drule visible_method_exists)
apply(fastforce simp:wf_cdecl_def dest!:class_wf dest:map_of_SomeD)
done
(*>*)


lemma sees_method_mono [rule_format (no_asm)]: 
  " P  C' * C; wf_prog wf_md P  
  D Ts T m. P  C sees M:TsT = m in D 
     (D' Ts' T' m'. P  C' sees M:Ts'T' = m' in D'  P  Ts [≤] Ts'  P  T'  T)"
(*<*)
apply( drule rtranclD)
apply( erule disjE)
apply(  fastforce)
apply( erule conjE)
apply( erule trancl_trans_induct)
prefer 2
apply(  clarify)
apply(  drule spec, drule spec, drule spec, drule spec, erule (1) impE)
apply clarify
apply(  fast elim: widen_trans widens_trans)
apply( clarify)
apply( drule subcls1D)
apply( clarify)
apply(clarsimp simp:Method_def)
apply(frule (2) sees_methods_rec)
apply(rule refl)
apply(case_tac "map_of ms M")
apply(rule_tac x = D in exI)
apply(rule_tac x = Ts in exI)
apply(rule_tac x = T in exI)
apply simp
apply(rule_tac x = m in exI)
apply(fastforce simp add:map_add_def split:option.split)
apply clarsimp
apply(rename_tac Ts' T' m')
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def Method_def)
apply( frule map_of_SomeD)
apply auto
apply(drule (1) bspec, simp)
apply(erule_tac x=D in allE, erule_tac x=Ts in allE, erule_tac x=T in allE)
apply(fastforce simp:map_add_def split:option.split)
done
(*>*)


lemma sees_method_mono2:
  " P  C' * C; wf_prog wf_md P;
     P  C sees M:TsT = m in D; P  C' sees M:Ts'T' = m' in D' 
   P  Ts [≤] Ts'  P  T'  T"
(*<*)by(blast dest:sees_method_mono sees_method_fun)(*>*)


lemma mdecls_visible:
assumes wf: "wf_prog wf_md P" and "class": "is_class P C"
shows "D fs ms. class P C = Some(D,fs,ms)
          Mm. P  C sees_methods Mm  ((M,Ts,T,m)  set ms. Mm M = Some((Ts,T,m),C))"
(*<*)
using wf "class"
proof (induct rule:subcls1_induct)
  case Object
  with wf have "distinct_fst ms"
    by (unfold class_def wf_prog_def wf_cdecl_def) (fastforce dest:map_of_SomeD)
  with Object show ?case by(fastforce intro!: sees_methods_Object map_of_SomeI)
next
  case Subcls
  with wf have "distinct_fst ms"
    by (unfold class_def wf_prog_def wf_cdecl_def) (fastforce dest:map_of_SomeD)
  with Subcls show ?case
    by(fastforce elim:sees_methods_rec dest:subcls1D map_of_SomeI
                simp:is_class_def)
qed
(*>*)


lemma mdecl_visible:
assumes wf: "wf_prog wf_md P" and C: "(C,S,fs,ms)  set P" and  m: "(M,Ts,T,m)  set ms"
shows "P  C sees M:TsT = m in C"
(*<*)
proof -
  from wf C have "class": "class P C = Some (S,fs,ms)"
    by (auto simp add: wf_prog_def class_def is_class_def intro: map_of_SomeI)
  from "class" have "is_class P C" by(auto simp:is_class_def)                   
  with assms "class" show ?thesis
    by(bestsimp simp:Method_def dest:mdecls_visible)
qed
(*>*)


lemma Call_lemma:
  " P  C sees M:TsT = m in D; P  C' * C; wf_prog wf_md P 
   D' Ts' T' m'.
       P  C' sees M:Ts'T' = m' in D'  P  Ts [≤] Ts'  P  T'  T  P  C' * D'
        is_type P T'  (Tset Ts'. is_type P T)  wf_md P D' (M,Ts',T',m')"
(*<*)
apply(frule (2) sees_method_mono)
apply(fastforce intro:sees_method_decl_above dest:sees_wf_mdecl
               simp: wf_mdecl_def)
done
(*>*)


lemma wf_prog_lift:
  assumes wf: "wf_prog (λP C bd. A P C bd) P"
  and rule:
  "wf_md C M Ts C T m bd.
   wf_prog wf_md P 
   P  C sees M:TsT = m in C    
   set Ts   types P 
   bd = (M,Ts,T,m) 
   A P C bd 
   B P C bd"
  shows "wf_prog (λP C bd. B P C bd) P"
(*<*)
proof -
  from wf show ?thesis
    apply (unfold wf_prog_def wf_cdecl_def)
    apply clarsimp
    apply (drule bspec, assumption)
    apply (unfold wf_mdecl_def)
    apply clarsimp
    apply (drule bspec, assumption)
    apply clarsimp
    apply (frule mdecl_visible [OF wf], assumption+)
    apply (frule is_type_pTs [OF wf], assumption+)
    apply (drule rule [OF wf], assumption+)
    apply auto
    done
qed
(*>*)


subsection‹Well-formedness and field lookup›

lemma wf_Fields_Ex:
  " wf_prog wf_md P; is_class P C   FDTs. P  C has_fields FDTs"
(*<*)
apply(frule class_Object)
apply(erule (1) subcls1_induct)
 apply(blast intro:has_fields_Object)
apply(blast intro:has_fields_rec dest:subcls1D)
done
(*>*)


lemma has_fields_types:
  " P  C has_fields FDTs; (FD,T)  set FDTs; wf_prog wf_md P   is_type P T"
(*<*)
apply(induct rule:Fields.induct)
 apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
done
(*>*)


lemma sees_field_is_type:
  " P  C sees F:T in D; wf_prog wf_md P   is_type P T"
(*<*)
by(fastforce simp: sees_field_def
            elim: has_fields_types map_of_SomeD[OF map_of_remap_SomeD])
(*>*)

lemma wf_syscls:
  "set SystemClasses  set P  wf_syscls P"
(*<*)
apply (simp add: image_def SystemClasses_def wf_syscls_def sys_xcpts_def
                 ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def)
 apply force
done
(*>*)

end

Theory WWellForm

(*  Title:      Jinja/J/WWellForm.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Weak well-formedness of Jinja programs›

theory WWellForm imports "../Common/WellForm" Expr begin

definition wwf_J_mdecl :: "J_prog  cname  J_mb mdecl  bool"
where
  "wwf_J_mdecl P C    λ(M,Ts,T,(pns,body)).
  length Ts = length pns  distinct pns  this  set pns  fv body  {this}  set pns"

lemma wwf_J_mdecl[simp]:
  "wwf_J_mdecl P C (M,Ts,T,pns,body) =
  (length Ts = length pns  distinct pns  this  set pns  fv body  {this}  set pns)"
(*<*)by(simp add:wwf_J_mdecl_def)(*>*)

abbreviation
  wwf_J_prog :: "J_prog  bool" where
  "wwf_J_prog == wf_prog wwf_J_mdecl"

end

Theory Equivalence

(*  Title:      Jinja/J/Equivalence.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Equivalence of Big Step and Small Step Semantics›

theory Equivalence imports BigStep SmallStep WWellForm begin

subsection‹Small steps simulate big step›

subsubsection "Cast"

lemma CastReds:
  "P  e,s →* e',s'  P  Cast C e,s →* Cast C e',s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CastRed)
done
(*>*)

lemma CastRedsNull:
  "P  e,s →* null,s'  P  Cast C e,s →* null,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule CastReds)
apply(rule RedCastNull)
done
(*>*)

lemma CastRedsAddr:
  " P  e,s →* addr a,s'; hp s' a = Some(D,fs); P  D * C  
  P  Cast C e,s →* addr a,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule CastReds)
apply(erule (1) RedCast)
done
(*>*)

lemma CastRedsFail:
  " P  e,s →* addr a,s'; hp s' a = Some(D,fs); ¬ P  D * C  
  P  Cast C e,s →* THROW ClassCast,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule CastReds)
apply(erule (1) RedCastFail)
done
(*>*)

lemma CastRedsThrow:
  " P  e,s →* throw a,s'   P  Cast C e,s →* throw a,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule CastReds)
apply(rule red_reds.CastThrow)
done
(*>*)

subsubsection "LAss"

lemma LAssReds:
  "P  e,s →* e',s'  P   V:=e,s →*  V:=e',s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule LAssRed)
done
(*>*)

lemma LAssRedsVal:
  " P  e,s →* Val v,(h',l')   P   V:=e,s →* unit,(h',l'(Vv))"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule LAssReds)
apply(rule RedLAss)
done
(*>*)

lemma LAssRedsThrow:
  " P  e,s →* throw a,s'   P   V:=e,s →* throw a,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule LAssReds)
apply(rule red_reds.LAssThrow)
done
(*>*)

subsubsection "BinOp"

lemma BinOp1Reds:
  "P  e,s →* e',s'  P   e «bop» e2, s →* e' «bop» e2, s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule BinOpRed1)
done
(*>*)

lemma BinOp2Reds:
  "P  e,s →* e',s'  P  (Val v) «bop» e, s →* (Val v) «bop» e', s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule BinOpRed2)
done
(*>*)

lemma BinOpRedsVal:
  " P  e1,s0 →* Val v1,s1; P  e2,s1 →* Val v2,s2; binop(bop,v1,v2) = Some v 
   P  e1 «bop» e2, s0 →* Val v,s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule BinOp1Reds)
apply(rule rtrancl_into_rtrancl)
 apply(erule BinOp2Reds)
apply(rule RedBinOp)
apply simp
done
(*>*)

lemma BinOpRedsThrow1:
  "P  e,s →* throw e',s'  P  e «bop» e2, s →* throw e', s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule BinOp1Reds)
apply(rule red_reds.BinOpThrow1)
done
(*>*)

lemma BinOpRedsThrow2:
  " P  e1,s0 →* Val v1,s1; P  e2,s1 →* throw e,s2
   P  e1 «bop» e2, s0 →* throw e,s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule BinOp1Reds)
apply(rule rtrancl_into_rtrancl)
 apply(erule BinOp2Reds)
apply(rule red_reds.BinOpThrow2)
done
(*>*)

subsubsection "FAcc"

lemma FAccReds:
  "P  e,s →* e',s'  P  eF{D}, s →* e'F{D}, s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule FAccRed)
done
(*>*)

lemma FAccRedsVal:
  "P  e,s →* addr a,s'; hp s' a = Some(C,fs); fs(F,D) = Some v 
   P  eF{D},s →* Val v,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAccReds)
apply(erule (1) RedFAcc)
done
(*>*)

lemma FAccRedsNull:
  "P  e,s →* null,s'  P  eF{D},s →* THROW NullPointer,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAccReds)
apply(rule RedFAccNull)
done
(*>*)

lemma FAccRedsThrow:
  "P  e,s →* throw a,s'  P  eF{D},s →* throw a,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAccReds)
apply(rule red_reds.FAccThrow)
done
(*>*)

subsubsection "FAss"

lemma FAssReds1:
  "P  e,s →* e',s'  P  eF{D}:=e2, s →* e'F{D}:=e2, s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule FAssRed1)
done
(*>*)

lemma FAssReds2:
  "P  e,s →* e',s'  P  Val vF{D}:=e, s →* Val vF{D}:=e', s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule FAssRed2)
done
(*>*)

lemma FAssRedsVal:
  " P  e1,s0 →* addr a,s1; P  e2,s1 →* Val v,(h2,l2); Some(C,fs) = h2 a  
  P  e1F{D}:=e2, s0 →* unit, (h2(a(C,fs((F,D)v))),l2)"
(*<*)
apply(rule rtrancl_trans)
 apply(erule FAssReds1)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAssReds2)
apply(rule RedFAss)
apply simp
done
(*>*)

lemma FAssRedsNull:
  " P  e1,s0 →* null,s1; P  e2,s1 →* Val v,s2  
  P  e1F{D}:=e2, s0 →* THROW NullPointer, s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule FAssReds1)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAssReds2)
apply(rule RedFAssNull)
done
(*>*)

lemma FAssRedsThrow1:
  "P  e,s →* throw e',s'  P  eF{D}:=e2, s →* throw e', s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAssReds1)
apply(rule red_reds.FAssThrow1)
done
(*>*)

lemma FAssRedsThrow2:
  " P  e1,s0 →* Val v,s1; P  e2,s1 →* throw e,s2 
   P  e1F{D}:=e2,s0 →* throw e,s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule FAssReds1)
apply(rule rtrancl_into_rtrancl)
 apply(erule FAssReds2)
apply(rule red_reds.FAssThrow2)
done
(*>*)

subsubsection";;"

lemma  SeqReds:
  "P  e,s →* e',s'  P  e;;e2, s →* e';;e2, s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule SeqRed)
done
(*>*)

lemma SeqRedsThrow:
  "P  e,s →* throw e',s'  P  e;;e2, s →* throw e', s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule SeqReds)
apply(rule red_reds.SeqThrow)
done
(*>*)

lemma SeqReds2:
  " P  e1,s0 →* Val v1,s1; P  e2,s1 →* e2',s2   P  e1;;e2, s0 →* e2',s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule SeqReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedSeq)
apply assumption
done
(*>*)


subsubsection"If"

lemma CondReds:
  "P  e,s →* e',s'  P  if (e) e1 else e2,s →* if (e') e1 else e2,s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CondRed)
done
(*>*)

lemma CondRedsThrow:
  "P  e,s →* throw a,s'  P  if (e) e1 else e2, s →* throw a,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule CondReds)
apply(rule red_reds.CondThrow)
done
(*>*)

lemma CondReds2T:
  "P  e,s0 →* true,s1; P  e1, s1 →* e',s2   P  if (e) e1 else e2, s0 →* e',s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedCondT)
apply assumption
done
(*>*)

lemma CondReds2F:
  "P  e,s0 →* false,s1; P  e2, s1 →* e',s2   P  if (e) e1 else e2, s0 →* e',s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedCondF)
apply assumption
done
(*>*)


subsubsection "While"

lemma WhileFReds:
  "P  b,s →* false,s'  P  while (b) c,s →* unit,s'"
(*<*)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedWhile)
apply(rule rtrancl_into_rtrancl)
 apply(erule CondReds)
apply(rule RedCondF)
done
(*>*)

lemma WhileRedsThrow:
  "P  b,s →* throw e,s'  P  while (b) c,s →* throw e,s'"
(*<*)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedWhile)
apply(rule rtrancl_into_rtrancl)
 apply(erule CondReds)
apply(rule red_reds.CondThrow)
done
(*>*)

lemma WhileTReds:
  " P  b,s0 →* true,s1; P  c,s1 →* Val v1,s2; P  while (b) c,s2 →* e,s3 
   P  while (b) c,s0 →* e,s3"
(*<*)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedWhile)
apply(rule rtrancl_trans)
 apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedCondT)
apply(rule rtrancl_trans)
 apply(erule SeqReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedSeq)
apply assumption
done
(*>*)

lemma WhileTRedsThrow:
  " P  b,s0 →* true,s1; P  c,s1 →* throw e,s2 
   P  while (b) c,s0 →* throw e,s2"
(*<*)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedWhile)
apply(rule rtrancl_trans)
 apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedCondT)
apply(rule rtrancl_into_rtrancl)
 apply(erule SeqReds)
apply(rule red_reds.SeqThrow)
done
(*>*)

subsubsection"Throw"

lemma ThrowReds:
  "P  e,s →* e',s'  P  throw e,s →* throw e',s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule ThrowRed)
done
(*>*)

lemma ThrowRedsNull:
  "P  e,s →* null,s'  P  throw e,s →* THROW NullPointer,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule ThrowReds)
apply(rule RedThrowNull)
done
(*>*)

lemma ThrowRedsThrow:
  "P  e,s →* throw a,s'  P  throw e,s →* throw a,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule ThrowReds)
apply(rule red_reds.ThrowThrow)
done
(*>*)

subsubsection "InitBlock"

lemma InitBlockReds_aux:
  "P  e,s →* e',s' 
  h l h' l' v. s = (h,l(Vv))  s' = (h',l') 
  P  {V:T := Val v; e},(h,l) →* {V:T := Val(the(l' V)); e'},(h',l'(V:=(l V)))"
(*<*)
apply(erule converse_rtrancl_induct2)
 apply(fastforce simp: fun_upd_same simp del:fun_upd_apply)
apply clarify
apply(rename_tac e0 X Y e1 h1 l1 h0 l0 h2 l2 v0)
apply(subgoal_tac "V  dom l1")
 prefer 2
 apply(drule red_lcl_incr)
 apply simp
apply clarsimp
apply(rename_tac v1)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule InitBlockRed)
  apply assumption
 apply simp
apply(erule_tac x = "l1(V := l0 V)" in allE)
apply(erule_tac x = v1 in allE)
apply(erule impE)
 apply(rule ext)
 apply(simp add:fun_upd_def)
apply(simp add:fun_upd_def)
done
(*>*)

lemma InitBlockReds:
 "P  e, (h,l(Vv)) →* e', (h',l') 
  P  {V:T := Val v; e}, (h,l) →* {V:T := Val(the(l' V)); e'}, (h',l'(V:=(l V)))"
(*<*)by(blast dest:InitBlockReds_aux)(*>*)

lemma InitBlockRedsFinal:
  " P  e,(h,l(Vv)) →* e',(h',l'); final e'  
  P  {V:T := Val v; e},(h,l) →* e',(h', l'(V := l V))"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule InitBlockReds)
apply(fast elim!:finalE intro:RedInitBlock InitBlockThrow)
done
(*>*)


subsubsection "Block"

lemma BlockRedsFinal:
assumes reds: "P  e0,s0 →* e2,(h2,l2)" and fin: "final e2"
shows "h0 l0. s0 = (h0,l0(V:=None))  P  {V:T; e0},(h0,l0) →* e2,(h2,l2(V:=l0 V))"
(*<*)
using reds
proof (induct rule:converse_rtrancl_induct2)
  case refl thus ?case
    by(fastforce intro:finalE[OF fin] RedBlock BlockThrow
                simp del:fun_upd_apply)
next
  case (step e0 s0 e1 s1)
  have red: "P  e0,s0  e1,s1"
   and reds: "P  e1,s1 →* e2,(h2,l2)"
   and IH: "h l. s1 = (h,l(V := None))
                 P  {V:T; e1},(h,l) →* e2,(h2, l2(V := l V))"
   and s0: "s0 = (h0, l0(V := None))" by fact+
  obtain h1 l1 where s1: "s1 = (h1,l1)" by fastforce
  show ?case
  proof cases
    assume "assigned V e0"
    then obtain v e where e0: "e0 = V := Val v;; e"
      by (unfold assigned_def)blast
    from red e0 s0 have e1: "e1 = unit;;e" and s1: "s1 = (h0, l0(V  v))"
      by auto
    from e1 fin have "e1  e2" by (auto simp:final_def)
    then obtain e' s' where red1: "P  e1,s1  e',s'"
      and reds': "P  e',s' →* e2,(h2,l2)"
      using converse_rtranclE2[OF reds] by blast
    from red1 e1 have es': "e' = e" "s' = s1" by auto
    show ?case using e0 s1 es' reds'
      by(fastforce intro!: InitBlockRedsFinal[OF _ fin] simp del:fun_upd_apply)
  next
    assume unass: "¬ assigned V e0"
    show ?thesis
    proof (cases "l1 V")
      assume None: "l1 V = None"
      hence "P  {V:T; e0},(h0,l0)  {V:T; e1},(h1, l1(V := l0 V))"
        using s0 s1 red by(simp add: BlockRedNone[OF _ _ unass])
      moreover
      have "P  {V:T; e1},(h1, l1(V := l0 V)) →* e2,(h2, l2(V := l0 V))"
        using IH[of _ "l1(V := l0 V)"] s1 None by(simp add:fun_upd_idem)
      ultimately show ?case by(rule converse_rtrancl_into_rtrancl)
    next
      fix v assume Some: "l1 V = Some v"
      hence "P  {V:T;e0},(h0,l0)  {V:T := Val v; e1},(h1,l1(V := l0 V))"
        using s0 s1 red by(simp add: BlockRedSome[OF _ _ unass])
      moreover
      have "P  {V:T := Val v; e1},(h1,l1(V:= l0 V)) →*
                e2,(h2,l2(V:=l0 V))"
        using InitBlockRedsFinal[OF _ fin,of _ _ "l1(V:=l0 V)" V]
              Some reds s1 by(simp add:fun_upd_idem)
      ultimately show ?case by(rule converse_rtrancl_into_rtrancl)
    qed
  qed
qed
(*>*)


subsubsection "try-catch"

lemma TryReds:
  "P  e,s →* e',s'  P  try e catch(C V) e2,s →* try e' catch(C V) e2,s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule TryRed)
done
(*>*)

lemma TryRedsVal:
  "P  e,s →* Val v,s'  P  try e catch(C V) e2,s →* Val v,s'"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule TryReds)
apply(rule RedTry)
done
(*>*)

lemma TryCatchRedsFinal:
  " P  e1,s0 →* Throw a,(h1,l1);  h1 a = Some(D,fs); P  D * C;
     P  e2, (h1, l1(V  Addr a)) →* e2', (h2,l2); final e2' 
   P  try e1 catch(C V) e2, s0 →* e2', (h2, l2(V := l1 V))"
(*<*)
apply(rule rtrancl_trans)
 apply(erule TryReds)
apply(rule converse_rtrancl_into_rtrancl)
 apply(rule RedTryCatch)
  apply fastforce
 apply assumption
apply(rule InitBlockRedsFinal)
 apply assumption
apply(simp)
done
(*>*)

lemma TryRedsFail:
  " P  e1,s →* Throw a,(h,l); h a = Some(D,fs); ¬ P  D * C 
   P  try e1 catch(C V) e2,s →* Throw a,(h,l)"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule TryReds)
apply(fastforce intro!: RedTryFail)
done
(*>*)

subsubsection "List"

lemma ListReds1:
  "P  e,s →* e',s'  P  e#es,s [→]* e' # es,s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule ListRed1)
done
(*>*)

lemma ListReds2:
  "P  es,s [→]* es',s'  P  Val v # es,s [→]* Val v # es',s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule ListRed2)
done
(*>*)

lemma ListRedsVal:
  " P  e,s0 →* Val v,s1; P  es,s1 [→]* es',s2 
   P  e#es,s0 [→]* Val v # es',s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule ListReds1)
apply(erule ListReds2)
done
(*>*)

subsubsection"Call"

text‹First a few lemmas on what happens to free variables during redction.›

lemma assumes wf: "wwf_J_prog P"
shows Red_fv: "P  e,(h,l)  e',(h',l')  fv e'  fv e"
  and  "P  es,(h,l) [→] es',(h',l')  fvs es'  fvs es"
(*<*)
proof (induct rule:red_reds_inducts)
  case (RedCall h l a C fs M Ts T pns body D vs)
  hence "fv body  {this}  set pns"
    using assms by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)
  with RedCall.hyps show ?case by fastforce
qed auto
(*>*)


lemma Red_dom_lcl:
  "P  e,(h,l)  e',(h',l')  dom l'  dom l  fv e" and
  "P  es,(h,l) [→] es',(h',l')  dom l'  dom l  fvs es"
(*<*)
proof (induct rule:red_reds_inducts)
  case RedLAss thus ?case by(force split:if_splits)
next
  case CallParams thus ?case by(force split:if_splits)
next
  case BlockRedNone thus ?case by clarsimp (fastforce split:if_splits)
next
  case BlockRedSome thus ?case by clarsimp (fastforce split:if_splits)
next
  case InitBlockRed thus ?case by clarsimp (fastforce split:if_splits)
qed auto
(*>*)

lemma Reds_dom_lcl:
  " wwf_J_prog P; P  e,(h,l) →* e',(h',l')   dom l'  dom l  fv e"
(*<*)
apply(erule converse_rtrancl_induct_red)
 apply blast
apply(blast dest: Red_fv Red_dom_lcl)
done
(*>*)

text‹Now a few lemmas on the behaviour of blocks during reduction.›

(* If you want to avoid the premise "distinct" further down …
consts upd_vals :: "locals ⇒ vname list ⇒ val list ⇒ val list"
primrec
"upd_vals l [] vs = []"
"upd_vals l (V#Vs) vs = (if V ∈ set Vs then hd vs else the(l V)) #
                        upd_vals l Vs (tl vs)"

lemma [simp]: "⋀vs. length(upd_vals l Vs vs) = length Vs"
by(induct Vs, auto)
*)
lemma override_on_upd_lemma:
  "(override_on f (g(ab)) A)(a := g a) = override_on f g (insert a A)"
(*<*)
apply(rule ext)
apply(simp add:override_on_def)
done

declare fun_upd_apply[simp del] map_upds_twist[simp del]
(*>*)


lemma blocksReds:
  "l.  length Vs = length Ts; length vs = length Ts; distinct Vs;
         P  e, (h,l(Vs [↦] vs)) →* e', (h',l') 
         P  blocks(Vs,Ts,vs,e), (h,l) →* blocks(Vs,Ts,map (the  l') Vs,e'), (h',override_on l' l (set Vs))"
(*<*)
proof(induct Vs Ts vs e rule:blocks_induct)
  case (1 V Vs T Ts v vs e) show ?case
    using InitBlockReds[OF "1.hyps"[of "l(Vv)"]] "1.prems"
    by(auto simp:override_on_upd_lemma)
qed auto
(*>*)


lemma blocksFinal:
 "l.  length Vs = length Ts; length vs = length Ts; final e  
       P  blocks(Vs,Ts,vs,e), (h,l) →* e, (h,l)"
(*<*)
proof(induct Vs Ts vs e rule:blocks_induct)
  case 1
  show ?case using "1.prems" InitBlockReds[OF "1.hyps"]
    by(fastforce elim!:finalE elim: rtrancl_into_rtrancl[OF _ RedInitBlock]
                                   rtrancl_into_rtrancl[OF _ InitBlockThrow])
qed auto
(*>*)


lemma blocksRedsFinal:
assumes wf: "length Vs = length Ts" "length vs = length Ts" "distinct Vs"
    and reds: "P  e, (h,l(Vs [↦] vs)) →* e', (h',l')"
    and fin: "final e'" and l'': "l'' = override_on l' l (set Vs)"
shows "P  blocks(Vs,Ts,vs,e), (h,l) →* e', (h',l'')"
(*<*)
proof -
  let ?bv = "blocks(Vs,Ts,map (the o l') Vs,e')"
  have "P  blocks(Vs,Ts,vs,e), (h,l) →* ?bv, (h',l'')"
    using l'' by simp (rule blocksReds[OF wf reds])
  also have "P  ?bv, (h',l'') →* e', (h',l'')"
    using wf by(fastforce intro:blocksFinal fin)
  finally show ?thesis .
qed
(*>*)

text‹An now the actual method call reduction lemmas.›

lemma CallRedsObj:
 "P  e,s →* e',s'  P  eM(es),s →* e'M(es),s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CallObj)
done
(*>*)


lemma CallRedsParams:
 "P  es,s [→]* es',s'  P  (Val v)M(es),s →* (Val v)M(es'),s'"
(*<*)
apply(erule rtrancl_induct2)
 apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CallParams)
done
(*>*)


lemma CallRedsFinal:
assumes wwf: "wwf_J_prog P"
and "P  e,s0 →* addr a,s1"
      "P  es,s1 [→]* map Val vs,(h2,l2)"
      "h2 a = Some(C,fs)" "P  C sees M:TsT = (pns,body) in D"
      "size vs = size pns"
and l2': "l2' = [this  Addr a, pns[↦]vs]"
and body: "P  body,(h2,l2') →* ef,(h3,l3)"
and "final ef"
shows "P  eM(es), s0 →* ef,(h3,l2)"
(*<*)
proof -
  have wf: "size Ts = size pns  distinct pns  this  set pns"
    and wt: "fv body  {this}  set pns"
    using assms by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)+
  from body[THEN Red_lcl_add, of l2]
  have body': "P  body,(h2,l2(this Addr a, pns[↦]vs)) →* ef,(h3,l2++l3)"
    by (simp add:l2')
  have "dom l3  {this}  set pns"
    using Reds_dom_lcl[OF wwf body] wt l2' set_take_subset by force
  hence eql2: "override_on (l2++l3) l2 ({this}  set pns) = l2"
    by(fastforce simp add:map_add_def override_on_def fun_eq_iff)
  have "P  eM(es),s0 →* (addr a)M(es),s1" by(rule CallRedsObj)(rule assms(2))
  also have "P  (addr a)M(es),s1 →*
                 (addr a)M(map Val vs),(h2,l2)"
    by(rule CallRedsParams)(rule assms(3))
  also have "P  (addr a)M(map Val vs), (h2,l2) 
                 blocks(this#pns, Class D#Ts, Addr a#vs, body), (h2,l2)"
    by(rule RedCall)(auto simp: assms wf, rule assms(5))
  also (rtrancl_into_rtrancl) have "P  blocks(this#pns, Class D#Ts, Addr a#vs, body), (h2,l2)
                 →* ef,(h3,override_on (l2++l3) l2 ({this}  set pns))"
    by(rule blocksRedsFinal, insert assms wf body', simp_all)
  finally show ?thesis using eql2 by simp
qed
(*>*)


lemma CallRedsThrowParams:
  " P  e,s0 →* Val v,s1;  P  es,s1 [→]* map Val vs1 @ throw a # es2,s2 
   P  eM(es),s0 →* throw a,s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule CallRedsObj)
apply(rule rtrancl_into_rtrancl)
 apply(erule CallRedsParams)
apply(rule CallThrowParams)
apply simp
done
(*>*)


lemma CallRedsThrowObj:
  "P  e,s0 →* throw a,s1  P  eM(es),s0 →* throw a,s1"
(*<*)
apply(rule rtrancl_into_rtrancl)
 apply(erule CallRedsObj)
apply(rule CallThrowObj)
done
(*>*)


lemma CallRedsNull:
  " P  e,s0 →* null,s1; P  es,s1 [→]* map Val vs,s2 
   P  eM(es),s0 →* THROW NullPointer,s2"
(*<*)
apply(rule rtrancl_trans)
 apply(erule CallRedsObj)
apply(rule rtrancl_into_rtrancl)
 apply(erule CallRedsParams)
apply(rule RedCallNull)
done
(*>*)

subsubsection "The main Theorem"

lemma assumes wwf: "wwf_J_prog P"
shows big_by_small: "P  e,s  e',s'  P  e,s →* e',s'"
and bigs_by_smalls: "P  es,s [⇒] es',s'  P  es,s [→]* es',s'"
(*<*)
proof (induct rule: eval_evals.inducts)
  case New thus ?case by (auto simp:RedNew)
next
  case NewFail thus ?case by (auto simp:RedNewFail)
next
  case Cast thus ?case by(fastforce intro:CastRedsAddr)
next
  case CastNull thus ?case by(simp add:CastRedsNull)
next
  case CastFail thus ?case by(fastforce intro!:CastRedsFail)
next
  case CastThrow thus ?case by(auto dest!:eval_final simp:CastRedsThrow)
next
  case Val thus ?case by simp
next
  case BinOp thus ?case by(auto simp:BinOpRedsVal)
next
  case BinOpThrow1 thus ?case by(auto dest!:eval_final simp: BinOpRedsThrow1)
next
  case BinOpThrow2 thus ?case by(auto dest!:eval_final simp: BinOpRedsThrow2)
next
  case Var thus ?case by (auto simp:RedVar)
next
  case LAss thus ?case by(auto simp: LAssRedsVal)
next
  case LAssThrow thus ?case by(auto dest!:eval_final simp: LAssRedsThrow)
next
  case FAcc thus ?case by(auto intro:FAccRedsVal)
next
  case FAccNull thus ?case by(simp add:FAccRedsNull)
next
  case FAccThrow thus ?case by(auto dest!:eval_final simp:FAccRedsThrow)
next
  case FAss thus ?case by(auto simp:FAssRedsVal)
next
  case FAssNull thus ?case by(auto simp:FAssRedsNull)
next
  case FAssThrow1 thus ?case by(auto dest!:eval_final simp:FAssRedsThrow1)
next
  case FAssThrow2 thus ?case by(auto dest!:eval_final simp:FAssRedsThrow2)
next
  case CallObjThrow thus ?case by(auto dest!:eval_final simp:CallRedsThrowObj)
next
  case CallNull thus ?case by(simp add:CallRedsNull)
next
  case CallParamsThrow thus ?case
    by(auto dest!:evals_final simp:CallRedsThrowParams)
next
  case (Call e s0 a s1 ps vs h2 l2 C fs M Ts T pns body D l2' e' h3 l3)
  have IHe: "P  e,s0 →* addr a,s1"
    and IHes: "P  ps,s1 [→]* map Val vs,(h2,l2)"
    and h2a: "h2 a = Some(C,fs)"
    and "method": "P  C sees M:TsT = (pns,body) in D"
    and same_length: "length vs = length pns"
    and l2': "l2' = [this  Addr a, pns[↦]vs]"
    and eval_body: "P  body,(h2, l2')  e',(h3, l3)"
    and IHbody: "P  body,(h2,l2') →* e',(h3,l3)" by fact+
  show "P  eM(ps),s0 →* e',(h3, l2)"
    using "method" same_length l2' h2a IHbody eval_final[OF eval_body]
    by(fastforce intro:CallRedsFinal[OF wwf IHe IHes])
next
  case Block thus ?case by(auto simp: BlockRedsFinal dest:eval_final)
next
  case Seq thus ?case by(auto simp:SeqReds2)
next
  case SeqThrow thus ?case by(auto dest!:eval_final simp: SeqRedsThrow)
next
  case CondT thus ?case by(auto simp:CondReds2T)
next
  case CondF thus ?case by(auto simp:CondReds2F)
next
  case CondThrow thus ?case by(auto dest!:eval_final simp:CondRedsThrow)
next
  case WhileF thus ?case by(auto simp:WhileFReds)
next
  case WhileT thus ?case by(auto simp: WhileTReds)
next
  case WhileCondThrow thus ?case by(auto dest!:eval_final simp: WhileRedsThrow)
next
  case WhileBodyThrow thus ?case by(auto dest!:eval_final simp: WhileTRedsThrow)
next
  case Throw thus ?case by(auto simp:ThrowReds)
next
  case ThrowNull thus ?case by(auto simp:ThrowRedsNull)
next
  case ThrowThrow thus ?case by(auto dest!:eval_final simp:ThrowRedsThrow)
next
  case Try thus ?case by(simp add:TryRedsVal)
next
  case TryCatch thus ?case by(fast intro!: TryCatchRedsFinal dest!:eval_final)
next
  case TryThrow thus ?case by(fastforce intro!:TryRedsFail)
next
  case Nil thus ?case by simp
next
  case Cons thus ?case
    by(fastforce intro!:Cons_eq_appendI[OF refl refl] ListRedsVal)
next
  case ConsThrow thus ?case by(fastforce elim: ListReds1)
qed
(*>*)


subsection‹Big steps simulates small step›

text‹This direction was carried out by Norbert Schirmer and Daniel
Wasserrab.›

text ‹The big step equivalent of RedWhile›:› 

lemma unfold_while: 
  "P  while(b) c,s  e',s'  =  P  if(b) (c;;while(b) c) else (unit),s  e',s'"
(*<*)
proof
  assume "P  while (b) c,s  e',s'"
  thus "P  if (b) (c;; while (b) c) else unit,s  e',s'"
    by cases (fastforce intro: eval_evals.intros)+
next
  assume "P  if (b) (c;; while (b) c) else unit,s  e',s'"
  thus "P  while (b) c,s  e',s'"
  proof (cases)
    fix a
    assume e': "e' = throw a"
    assume "P  b,s  throw a,s'"  
    hence "P  while(b) c,s  throw a,s'" by (rule WhileCondThrow)
    with e' show ?thesis by simp
  next
    fix s1
    assume eval_false: "P  b,s  false,s1"
    and eval_unit: "P  unit,s1  e',s'"
    with eval_unit have "s' = s1" "e' = unit" by (auto elim: eval_cases)
    moreover from eval_false have "P  while (b) c,s  unit,s1"
      by - (rule WhileF, simp)
    ultimately show ?thesis by simp
  next
    fix s1
    assume eval_true: "P  b,s  true,s1"
    and eval_rest: "P  c;; while (b) c,s1e',s'"
    from eval_rest show ?thesis
    proof (cases)
      fix s2 v1
      assume "P  c,s1  Val v1,s2" "P  while (b) c,s2  e',s'"
      with eval_true show "P  while(b) c,s  e',s'" by (rule WhileT)
    next
      fix a
      assume "P  c,s1  throw a,s'" "e' = throw a"
      with eval_true show "P  while(b) c,s  e',s'"        
        by (iprover intro: WhileBodyThrow)
    qed
  qed
qed
(*>*)


lemma blocksEval:
  "Ts vs l l'. size ps = size Ts; size ps = size vs; P  blocks(ps,Ts,vs,e),(h,l)  e',(h',l') 
      l''. P  e,(h,l(ps[↦]vs))  e',(h',l'')"
(*<*)
proof (induct ps)
  case Nil then show ?case by fastforce
next
  case (Cons p ps')
  have length_eqs: "length (p # ps') = length Ts" 
                   "length (p # ps') = length vs" by fact+
  then obtain T Ts' where Ts: "Ts = T#Ts'" by (cases "Ts") simp
  obtain v vs' where vs: "vs = v#vs'" using length_eqs by (cases "vs") simp
  have "P  blocks (p # ps', Ts, vs, e),(h,l)  e',(h', l')" by fact
  with Ts vs 
  have "P  {p:T := Val v; blocks (ps', Ts', vs', e)},(h,l)  e',(h', l')"
    by simp
  then obtain l''' where
    eval_ps': "P  blocks (ps', Ts', vs', e),(h, l(pv))  e',(h', l''')"
    and l''': "l'=l'''(p:=l p)"
    by (auto elim!: eval_cases)
  then obtain l'' where 
    hyp: "P  e,(h, l(pv)(ps'[↦]vs'))  e',(h', l'')"
    using length_eqs Ts vs Cons.hyps [OF _ _ eval_ps'] by auto
  from hyp
  show "l''. P  e,(h, l(p # ps'[↦]vs))  e',(h', l'')"
    using Ts vs by auto
qed
(*>*)
(* FIXME exercise: show precise relationship between l' and l'':
lemma blocksEval:
  "⋀ Ts vs l l'. ⟦length ps = length Ts; length ps = length vs; 
        P⊢ ⟨blocks(ps,Ts,vs,e),(h,l)⟩ ⇒ ⟨e',(h',l')⟩ ⟧
    ⟹ ∃ l''. P ⊢ ⟨e,(h,l(ps[↦]vs))⟩ ⇒ ⟨e',(h',l'')⟩ ∧ l'=l''(l|set ps)"
proof (induct ps)
  case Nil then show ?case by simp
next
  case (Cons p ps')
  have length_eqs: "length (p # ps') = length Ts" 
                   "length (p # ps') = length vs" .
  then obtain T Ts' where Ts: "Ts=T#Ts'" by (cases "Ts") simp
  obtain v vs' where vs: "vs=v#vs'" using length_eqs by (cases "vs") simp
  have "P ⊢ ⟨blocks (p # ps', Ts, vs, e),(h,l)⟩ ⇒ ⟨e',(h', l')⟩".
  with Ts vs 
  have "P ⊢ ⟨{p:T := Val v; blocks (ps', Ts', vs', e)},(h,l)⟩ ⇒ ⟨e',(h', l')⟩"
    by simp
  then obtain l''' where
    eval_ps': "P ⊢ ⟨blocks (ps', Ts', vs', e),(h, l(p↦v))⟩ ⇒ ⟨e',(h', l''')⟩"
    and l''': "l'=l'''(p:=l p)"
    by (cases) (auto elim: eval_cases)
 
  then obtain l'' where 
    hyp: "P ⊢ ⟨e,(h, l(p↦v)(ps'[↦]vs'))⟩ ⇒ ⟨e',(h', l'')⟩" and
    l'': "l''' = l''(l(p↦v)|set ps')"
    using length_eqs Ts vs Cons.hyps [OF _ _ eval_ps'] by auto
  have "l' = l''(l|set (p # ps'))"
  proof -
    have "(l''(l(p↦v)|set ps'))(p := l p) = l''(l|insert p (set ps'))"
      by (induct ps') (auto intro: ext simp add: fun_upd_def override_on_def)
    with l''' l'' show ?thesis  by simp
  qed
  with hyp
  show "∃l''. P ⊢ ⟨e,(h, l(p # ps'[↦]vs))⟩ ⇒ ⟨e',(h', l'')⟩ ∧
        l' = l''(l|set (p # ps'))"
    using Ts vs by auto
qed
*)

lemma
assumes wf: "wwf_J_prog P"
shows eval_restrict_lcl:
  "P  e,(h,l)  e',(h',l')  (W. fv e  W  P  e,(h,l|`W)  e',(h',l'|`W))"
and "P  es,(h,l) [⇒] es',(h',l')  (W. fvs es  W  P  es,(h,l|`W) [⇒] es',(h',l'|`W))"
(*<*)
proof(induct rule:eval_evals_inducts)
  case (Block e0 h0 l0 V e1 h1 l1 T)
  have IH: "W. fv e0  W  P  e0,(h0,l0(V:=None)|`W)  e1,(h1,l1|`W)" by fact
  have "fv({V:T; e0})  W" by fact+
  hence "fv e0 - {V}  W" by simp_all
  hence "fv e0  insert V W" by fast
  from IH[OF this]
  have "P  e0,(h0, (l0|`W)(V := None))  e1,(h1, l1|`insert V W)"
    by fastforce
  from eval_evals.Block[OF this] show ?case by fastforce
next
  case Seq thus ?case by simp (blast intro:eval_evals.Seq)
next
  case New thus ?case by(simp add:eval_evals.intros)
next
  case NewFail thus ?case by(simp add:eval_evals.intros)
next
  case Cast thus ?case by simp (blast intro:eval_evals.Cast)
next
  case CastNull thus ?case by simp (blast intro:eval_evals.CastNull)
next
  case CastFail thus ?case by simp (blast intro:eval_evals.CastFail)
next
  case CastThrow thus ?case by(simp add:eval_evals.intros)
next
  case Val thus ?case by(simp add:eval_evals.intros)
next
  case BinOp thus ?case by simp (blast intro:eval_evals.BinOp)
next
  case BinOpThrow1 thus ?case by simp (blast intro:eval_evals.BinOpThrow1)
next
  case BinOpThrow2 thus ?case by simp (blast intro:eval_evals.BinOpThrow2)
next
  case Var thus ?case by(simp add:eval_evals.intros)
next
  case (LAss e h0 l0 v h l l' V)
  have IH: "W. fv e  W  P  e,(h0,l0|`W)  Val v,(h,l|`W)"
   and [simp]: "l' = l(V  v)" by fact+
  have "fv (V:=e)  W" by fact
  hence fv: "fv e  W" and VinW: "V  W" by auto
  from eval_evals.LAss[OF IH[OF fv] refl, of V] VinW
  show ?case by simp
next
  case LAssThrow thus ?case by(fastforce intro: eval_evals.LAssThrow)
next
  case FAcc thus ?case by simp (blast intro: eval_evals.FAcc)
next
  case FAccNull thus ?case by(fastforce intro: eval_evals.FAccNull)
next
  case FAccThrow thus ?case by(fastforce intro: eval_evals.FAccThrow)
next
  case FAss thus ?case by simp (blast intro: eval_evals.FAss)
next
  case FAssNull thus ?case by simp (blast intro: eval_evals.FAssNull)
next
  case FAssThrow1 thus ?case by simp (blast intro: eval_evals.FAssThrow1)
next
  case FAssThrow2 thus ?case by simp (blast intro: eval_evals.FAssThrow2)
next
  case CallObjThrow thus ?case by simp (blast intro: eval_evals.intros)
next
  case CallNull thus ?case by simp (blast intro: eval_evals.CallNull)
next
  case CallParamsThrow thus ?case
    by simp (blast intro: eval_evals.CallParamsThrow)
next
  case (Call e h0 l0 a h1 l1 ps vs h2 l2 C fs M Ts T pns body
      D l2' e' h3 l3)
  have IHe: "W. fv e  W  P  e,(h0,l0|`W)  addr a,(h1,l1|`W)"
   and IHps: "W. fvs ps  W  P  ps,(h1,l1|`W) [⇒] map Val vs,(h2,l2|`W)"
   and IHbd: "W. fv body  W  P  body,(h2,l2'|`W)  e',(h3,l3|`W)"
   and h2a: "h2 a = Some (C, fs)"
   and "method": "P  C sees M: TsT = (pns, body) in D"
   and same_len: "size vs = size pns"
   and l2': "l2' = [this  Addr a, pns [↦] vs]" by fact+
  have "fv (eM(ps))  W" by fact
  hence fve: "fv e   W" and fvps: "fvs(ps)  W" by auto
  have wfmethod: "size Ts = size pns  this  set pns" and
       fvbd: "fv body  {this}  set pns"
    using "method" wf by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)+
  show ?case
    using IHbd[OF fvbd] l2' same_len wfmethod h2a
      eval_evals.Call[OF IHe[OF fve] IHps[OF fvps] _ "method" same_len l2']
    by (simp add:subset_insertI)
next
  case SeqThrow thus ?case by simp (blast intro: eval_evals.SeqThrow)
next
  case CondT thus ?case by simp (blast intro: eval_evals.CondT)
next
  case CondF thus ?case by simp (blast intro: eval_evals.CondF)
next
  case CondThrow thus ?case by simp (blast intro: eval_evals.CondThrow)
next
  case WhileF thus ?case by simp (blast intro: eval_evals.WhileF)
next
  case WhileT thus ?case by simp (blast intro: eval_evals.WhileT)
next
  case WhileCondThrow thus ?case by simp (blast intro: eval_evals.WhileCondThrow)
next
  case WhileBodyThrow thus ?case by simp (blast intro: eval_evals.WhileBodyThrow)
next
  case Throw thus ?case by simp (blast intro: eval_evals.Throw)
next
  case ThrowNull thus ?case by simp (blast intro: eval_evals.ThrowNull)
next
  case ThrowThrow thus ?case by simp (blast intro: eval_evals.ThrowThrow)
next
  case Try thus ?case by simp (blast intro: eval_evals.Try)
next
  case (TryCatch e1 h0 l0 a h1 l1 D fs C e2 V e2' h2 l2)
  have IH1: "W. fv e1  W  P  e1,(h0,l0|`W)  Throw a,(h1,l1|`W)"
   and IH2: "W. fv e2  W  P  e2,(h1,l1(VAddr a)|`W)  e2',(h2,l2|`W)"
   and lookup: "h1 a = Some(D, fs)" and subtype: "P  D * C" by fact+
  have "fv (try e1 catch(C V) e2)  W" by fact
  hence fv1: "fv e1  W" and fv2: "fv e2  insert V W" by auto
  have IH2': "P  e2,(h1,(l1|`W)(V  Addr a))  e2',(h2,l2|`insert V W)"
    using IH2[OF fv2] fun_upd_restrict[of l1 W] (*FIXME just l|W instead of l|(W-V) in simp rule??*) by simp
  with eval_evals.TryCatch[OF IH1[OF fv1] _ subtype IH2'] lookup
  show ?case by fastforce
next
  case TryThrow thus ?case by simp (blast intro: eval_evals.TryThrow)
next
  case Nil thus ?case by (simp add: eval_evals.Nil)
next
  case Cons thus ?case by simp (blast intro: eval_evals.Cons)
next
  case ConsThrow thus ?case by simp (blast intro: eval_evals.ConsThrow)
qed
(*>*)


lemma eval_notfree_unchanged:
  "P  e,(h,l)  e',(h',l')  (V. V  fv e  l' V = l V)"
and "P  es,(h,l) [⇒] es',(h',l')  (V. V  fvs es  l' V = l V)"
(*<*)
proof(induct rule:eval_evals_inducts)
  case LAss thus ?case by(simp add:fun_upd_apply)
next
  case Block thus ?case
    by (simp only:fun_upd_apply split:if_splits) fastforce
next
  case TryCatch thus ?case
    by (simp only:fun_upd_apply split:if_splits) fastforce
qed simp_all
(*>*)


lemma eval_closed_lcl_unchanged:
  " P  e,(h,l)  e',(h',l'); fv e = {}   l' = l"
(*<*)by(fastforce dest:eval_notfree_unchanged simp add:fun_eq_iff [where 'b="val option"])(*>*)


lemma list_eval_Throw: 
assumes eval_e: "P  throw x,s  e',s'"
shows "P  map Val vs @ throw x # es',s [⇒] map Val vs @ e' # es',s'"
(*<*)
proof -
  from eval_e 
  obtain a where e': "e' = Throw a"
    by (cases) (auto dest!: eval_final)
  {
    fix es
    have "vs. es = map Val vs @ throw x # es' 
            P  es,s[⇒]map Val vs @ e' # es',s'"
    proof (induct es type: list)
      case Nil thus ?case by simp
    next
      case (Cons e es vs)
      have e_es: "e # es = map Val vs @ throw x # es'" by fact
      show "P  e # es,s [⇒] map Val vs @ e' # es',s'"
      proof (cases vs)
        case Nil
        with e_es obtain "e=throw x" "es=es'" by simp
        moreover from eval_e e'
        have "P  throw x # es,s [⇒] Throw a # es,s'"
          by (iprover intro: ConsThrow)
        ultimately show ?thesis using Nil e' by simp
      next
        case (Cons v vs')
        have vs: "vs = v # vs'" by fact
        with e_es obtain 
          e: "e=Val v" and es:"es= map Val vs' @ throw x # es'"
          by simp
        from e 
        have "P  e,s  Val v,s"
          by (iprover intro: eval_evals.Val)
        moreover from es 
        have "P  es,s [⇒] map Val vs' @ e' # es',s'"
          by (rule Cons.hyps)
        ultimately show 
          "P  e#es,s [⇒] map Val vs @ e' # es',s'"
          using vs by (auto intro: eval_evals.Cons)
      qed
    qed
  }
  thus ?thesis
    by simp
qed
(*>*)
(* Hiermit kann man die ganze pair-Splitterei in den automatischen Taktiken
abschalten. Wieder anschalten siehe nach dem Beweis. *)
(*<*)
declare split_paired_All [simp del] split_paired_Ex [simp del]
(*>*)
(* FIXME
 exercise 1: define a big step semantics where the body of a procedure can
 access not juts this and pns but all of the enclosing l. What exactly is fed
 in? What exactly is returned at the end? Notion: "dynamic binding"

  excercise 2: the semantics of exercise 1 is closer to the small step
  semantics. Reformulate equivalence proof by modifying call lemmas.
*)
text ‹The key lemma:›

lemma
assumes wf: "wwf_J_prog P"
shows extend_1_eval:
  "P  e,s  e'',s''   (s' e'. P  e'',s''  e',s'  P  e,s  e',s')"
and extend_1_evals:
  "P  es,t [→] es'',t''  (t' es'. P  es'',t'' [⇒] es',t'  P  es,t [⇒] es',t')"
(*<*)
proof (induct rule: red_reds.inducts)
  case (RedCall s a C fs M Ts T pns body D vs s' e')
  have "P  addr a,s  addr a,s" by (rule eval_evals.intros)
  moreover
  have finals: "finals(map Val vs)" by simp
  obtain h2 l2 where s: "s = (h2,l2)" by (cases s)
  with finals have "P  map Val vs,s [⇒] map Val vs,(h2,l2)"
    by (iprover intro: eval_finalsId)
  moreover from s have "h2 a = Some (C, fs)" using RedCall by simp
  moreover have "method": "P  C sees M: TsT = (pns, body) in D" by fact
  moreover have same_len1: "length Ts = length pns"
   and this_distinct: "this  set pns" and fv: "fv body  {this}  set pns"
    using "method" wf by (fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)+
  have same_len: "length vs = length pns" by fact
  moreover
  obtain l2' where l2': "l2' = [thisAddr a,pns[↦]vs]" by simp
  moreover
  obtain h3 l3 where s': "s' = (h3,l3)" by (cases s')
  have eval_blocks:
    "P  blocks (this # pns, Class D # Ts, Addr a # vs, body),s  e',s'" by fact
  hence id: "l3 = l2" using fv s s' same_len1 same_len
    by(fastforce elim: eval_closed_lcl_unchanged)
  from eval_blocks obtain l3' where "P  body,(h2,l2')  e',(h3,l3')"
  proof -
    from same_len1 have "length(this#pns) = length(Class D#Ts)" by simp
    moreover from same_len1 same_len
    have "length (this#pns) = length (Addr a#vs)" by simp
    moreover from eval_blocks
    have "P  blocks (this#pns,Class D#Ts,Addr a#vs,body),(h2,l2)
              e',(h3,l3)" using s s' by simp
    ultimately obtain l''
      where "P  body,(h2,l2(this # pns[↦]Addr a # vs))e',(h3, l'')"
      by (blast dest:blocksEval)
    from eval_restrict_lcl[OF wf this fv] this_distinct same_len1 same_len
    have "P  body,(h2,[this # pns[↦]Addr a # vs]) 
               e',(h3, l''|`(set(this#pns)))"
      by(simp add:subset_insert_iff insert_Diff_if)
    thus ?thesis by(fastforce intro!:that simp add: l2')
  qed
  ultimately
  have "P  (addr a)M(map Val vs),s  e',(h3,l2)" by (rule Call)
  with s' id show ?case by simp
next
 case RedNew
  thus ?case
     by (iprover elim: eval_cases intro: eval_evals.intros)
next
  case RedNewFail
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case (CastRed e s e'' s'' C s' e')
  thus ?case
    by(cases s, cases s') (erule eval_cases, auto intro: eval_evals.intros)
next
  case RedCastNull
  thus ?case
    by (iprover elim: eval_cases intro: eval_evals.intros)
next
  case (RedCast s a D fs C s'' e'')
  thus ?case
    by (cases s) (auto elim: eval_cases intro: eval_evals.intros)
next
  case (RedCastFail s a D fs C s'' e'')
  thus ?case
    by (cases s) (auto elim!: eval_cases intro: eval_evals.intros)
next
  case (BinOpRed1 e s e' s' bop e2 s'' e')
  thus ?case
    by (cases s'')(erule eval_cases,auto intro: eval_evals.intros)
next
  case BinOpRed2
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId)
next
  case RedBinOp
  thus ?case
    by (iprover elim: eval_cases intro: eval_evals.intros)
next
  case (RedVar s V v s' e')
  thus ?case
    by (cases s)(fastforce elim: eval_cases intro: eval_evals.intros)
next
  case (LAssRed e s e' s' V s'')
  thus ?case
    by (cases s'')(erule eval_cases,auto intro: eval_evals.intros)
next
  case RedLAss
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case (FAccRed e s e' s' F D s'')
  thus ?case
    by (cases s'')(erule eval_cases,auto intro: eval_evals.intros)
next
  case (RedFAcc s a C fs F D v s' e')
  thus ?case
    by (cases s)(fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedFAccNull
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
  case (FAssRed1 e s e' s'' F D e2 s' e')
  thus ?case
    by (cases s')(erule eval_cases, auto intro: eval_evals.intros)
next
  case (FAssRed2 e s e' s'' v F D s' e')
  thus ?case
    by (cases s)
       (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId)
next
  case RedFAss
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
  case RedFAssNull
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
  case CallObj
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
  case CallParams
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId)
next
  case RedCallNull
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros eval_finalsId)
next
  case InitBlockRed
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId
                 simp add: map_upd_triv fun_upd_same)
next
  case (RedInitBlock V T v u s s' e')
  have "P  Val u,s  e',s'" by fact
  then obtain s': "s'=s" and e': "e'=Val u" by cases simp
  obtain h l where s: "s=(h,l)" by (cases s)
  have "P  {V:T :=Val v; Val u},(h,l)  Val u,(h, (l(Vv))(V:=l V))"
    by (fastforce intro!: eval_evals.intros)
  thus "P  {V:T := Val v; Val u},s  e',s'"
    using s s' e' by simp
next
  case BlockRedNone
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros 
                 simp add: fun_upd_same fun_upd_idem)
next
  case BlockRedSome
  thus ?case
    by (fastforce elim!: eval_cases intro: eval_evals.intros 
                 simp add:  fun_upd_same fun_upd_idem)
next
 case (RedBlock V T v s s' e') 
 have "P  Val v,s  e',s'" by fact
 then obtain s': "s'=s" and e': "e'=Val v" 
    by cases simp
  obtain h l where s: "s=(h,l)" by (cases s)
 have "P  Val v,(h,l(V:=None))  Val v,(h,l(V:=None))" 
   by (rule eval_evals.intros)
 hence "P  {V:T;Val v},(h,l)  Val v,(h,(l(V:=None))(V:=l V))"
   by (rule eval_evals.Block)
 thus "P  {V:T; Val v},s  e',s'"
    using s s' e'
    by simp
next
  case SeqRed
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedSeq
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case CondRed
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedCondT
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedCondF
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedWhile
  thus ?case
    by (auto simp add: unfold_while intro:eval_evals.intros elim:eval_cases)
next
  case ThrowRed
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedThrowNull
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case (TryRed e s e' s' C V e2 s'' e')
  thus ?case
    by (cases s, cases s'', auto elim!: eval_cases intro: eval_evals.intros)
next
  case RedTry
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case RedTryCatch
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case (RedTryFail s a D fs C V e2 s' e')
  thus ?case
    by (cases s)(auto elim!: eval_cases intro: eval_evals.intros)
next
  case ListRed1
  thus ?case
    by (fastforce elim: evals_cases intro: eval_evals.intros)
next
  case ListRed2
  thus ?case
    by (fastforce elim!: evals_cases eval_cases 
                 intro: eval_evals.intros eval_finalId)
next
  case CastThrow
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case BinOpThrow1
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case BinOpThrow2
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case LAssThrow
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case FAccThrow
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case FAssThrow1
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case FAssThrow2
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case CallThrowObj
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case (CallThrowParams es vs e es' v M s s' e')
  have "P  Val v,s  Val v,s" by (rule eval_evals.intros)
  moreover
  have es: "es = map Val vs @ throw e # es'" by fact
  have eval_e: "P  throw e,s  e',s'" by fact
  then obtain xa where e': "e' = Throw xa" by (cases) (auto dest!: eval_final)
  with list_eval_Throw [OF eval_e] es
  have "P  es,s [⇒] map Val vs @ Throw xa # es',s'" by simp
  ultimately have "P  Val vM(es),s  Throw xa,s'"
    by (rule eval_evals.CallParamsThrow)
  thus ?case using e' by simp
next
  case (InitBlockThrow V T v a s s' e')
  have "P  Throw a,s  e',s'" by fact
  then obtain s': "s' = s" and e': "e' = Throw a"
    by cases (auto elim!:eval_cases)
  obtain h l where s: "s = (h,l)" by (cases s)
  have "P  {V:T :=Val v; Throw a},(h,l)  Throw a, (h, (l(Vv))(V:=l V))"
    by(fastforce intro:eval_evals.intros)
  thus "P  {V:T := Val v; Throw a},s  e',s'" using s s' e' by simp
next
  case (BlockThrow V T a s s' e')
  have "P  Throw a, s  e',s'" by fact
  then obtain s': "s' = s" and e': "e' = Throw a"
    by cases (auto elim!:eval_cases)
  obtain h l where s: "s=(h,l)" by (cases s)
  have "P  Throw a, (h,l(V:=None))  Throw a, (h,l(V:=None))"
    by (simp add:eval_evals.intros eval_finalId)
  hence "P{V:T;Throw a},(h,l)Throw a, (h,(l(V:=None))(V:=l V))"
    by (rule eval_evals.Block)
  thus "P  {V:T; Throw a},s  e',s'" using s s' e' by simp
next
  case SeqThrow
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case CondThrow
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
next
  case ThrowThrow
  thus ?case
    by (fastforce elim: eval_cases intro: eval_evals.intros)
qed
(*>*)
(*<*)
(* ... und wieder anschalten: *)
declare split_paired_All [simp] split_paired_Ex [simp]
(*>*)

text ‹Its extension to →*›:› 

lemma extend_eval:
assumes wf: "wwf_J_prog P"
and reds: "P  e,s →* e'',s''" and eval_rest:  "P  e'',s''  e',s'"
shows "P  e,s  e',s'"
(*<*)
using reds eval_rest 
apply (induct rule: converse_rtrancl_induct2)
apply simp
apply simp
apply (rule extend_1_eval)
apply (rule wf)
apply assumption
apply assumption
done
(*>*)


lemma extend_evals:
assumes wf: "wwf_J_prog P"
and reds: "P  es,s [→]* es'',s''" and eval_rest:  "P  es'',s'' [⇒] es',s'"
shows "P  es,s [⇒] es',s'"
(*<*)
using reds eval_rest 
apply (induct rule: converse_rtrancl_induct2)
apply simp
apply simp
apply (rule extend_1_evals)
apply (rule wf)
apply assumption
apply assumption
done
(*>*)

text ‹Finally, small step semantics can be simulated by big step semantics:
›

theorem
assumes wf: "wwf_J_prog P"
shows small_by_big: "P  e,s →* e',s'; final e'  P  e,s  e',s'"
and "P  es,s [→]* es',s'; finals es'  P  es,s [⇒] es',s'"
(*<*)
proof -
  note wf 
  moreover assume "P  e,s →* e',s'"
  moreover assume "final e'"
  then have "P  e',s'  e',s'"
    by (rule eval_finalId)
  ultimately show "P  e,se',s'"
    by (rule extend_eval)
next
  note wf 
  moreover assume "P  es,s [→]* es',s'"
  moreover assume "finals es'"
  then have "P  es',s' [⇒] es',s'"
    by (rule eval_finalsId)
  ultimately show "P  es,s [⇒] es',s'"
    by (rule extend_evals)
qed
(*>*)

subsection "Equivalence"

text‹And now, the crowning achievement:›

corollary big_iff_small:
  "wwf_J_prog P 
  P  e,s  e',s'  =  (P  e,s →* e',s'  final e')"
(*<*)by(blast dest: big_by_small eval_final small_by_big)(*>*)


end

Theory WellType

(*  Title:      Jinja/J/WellType.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Well-typedness of Jinja expressions›

theory WellType
imports "../Common/Objects" Expr
begin

type_synonym
  env  = "vname  ty"

inductive
  WT :: "[J_prog,env, expr     , ty     ]  bool"
         ("_,_  _ :: _"   [51,51,51]50)
  and WTs :: "[J_prog,env, expr list, ty list]  bool"
         ("_,_  _ [::] _" [51,51,51]50)
  for P :: J_prog
where
  
  WTNew:
  "is_class P C  
  P,E  new C :: Class C"

| WTCast:
  " P,E  e :: Class D;  is_class P C;  P  C * D  P  D * C 
   P,E  Cast C e :: Class C"

| WTVal:
  "typeof v = Some T 
  P,E  Val v :: T"

| WTVar:
  "E V = Some T 
  P,E  Var V :: T"
(*
WTBinOp:
  "⟦ P,E ⊢ e1 :: T1;  P,E ⊢ e2 :: T2;
     case bop of Eq ⇒ (P ⊢ T1 ≤ T2 ∨ P ⊢ T2 ≤ T1) ∧ T = Boolean
               | Add ⇒ T1 = Integer ∧ T2 = Integer ∧ T = Integer ⟧
  ⟹ P,E ⊢ e1 «bop» e2 :: T"
*)
| WTBinOpEq:
  " P,E  e1 :: T1;  P,E  e2 :: T2; P  T1  T2  P  T2  T1 
   P,E  e1 «Eq» e2 :: Boolean"

| WTBinOpAdd:
  " P,E  e1 :: Integer;  P,E  e2 :: Integer 
   P,E  e1 «Add» e2 :: Integer"

| WTLAss:
  " E V = Some T;  P,E  e :: T';  P  T'  T;  V  this 
   P,E  V:=e :: Void"

| WTFAcc:
  " P,E  e :: Class C;  P  C sees F:T in D 
   P,E  eF{D} :: T"

| WTFAss:
  " P,E  e1 :: Class C;  P  C sees F:T in D;  P,E  e2 :: T';  P  T'  T 
   P,E  e1F{D}:=e2 :: Void"

| WTCall:
  " P,E  e :: Class C;  P  C sees M:Ts  T = (pns,body) in D;
     P,E  es [::] Ts';  P  Ts' [≤] Ts 
   P,E  eM(es) :: T"

| WTBlock:
  " is_type P T;  P,E(V  T)  e :: T' 
    P,E  {V:T; e} :: T'"

| WTSeq:
  " P,E  e1::T1;  P,E  e2::T2 
    P,E  e1;;e2 :: T2"
| WTCond:
  " P,E  e :: Boolean;  P,E  e1::T1;  P,E  e2::T2;
     P  T1  T2  P  T2  T1;  P  T1  T2  T = T2;  P  T2  T1  T = T1 
   P,E  if (e) e1 else e2 :: T"

| WTWhile:
  " P,E  e :: Boolean;  P,E  c::T 
   P,E  while (e) c :: Void"

| WTThrow:
  "P,E  e :: Class C   
  P,E  throw e :: Void"

| WTTry:
  " P,E  e1 :: T;  P,E(V  Class C)  e2 :: T; is_class P C 
   P,E  try e1 catch(C V) e2 :: T"

― ‹well-typed expression lists›

| WTNil:
  "P,E  [] [::] []"

| WTCons:
  " P,E  e :: T;  P,E  es [::] Ts 
    P,E  e#es [::] T#Ts"

(*<*)
(*
lemmas [intro!] = WTNew WTCast WTVal WTVar WTBinOp WTLAss WTFAcc WTFAss WTCall WTBlock WTSeq
                  WTWhile WTThrow WTTry WTNil WTCons
lemmas [intro]  = WTCond1 WTCond2
*)
declare WT_WTs.intros[intro!] (* WTNil[iff] *)

lemmas WT_WTs_induct = WT_WTs.induct [split_format (complete)]
  and WT_WTs_inducts = WT_WTs.inducts [split_format (complete)]
(*>*)

lemma [iff]: "(P,E  [] [::] Ts) = (Ts = [])"
(*<*)
apply(rule iffI)
apply (auto elim: WTs.cases)
done
(*>*)

lemma [iff]: "(P,E  e#es [::] T#Ts) = (P,E  e :: T  P,E  es [::] Ts)"
(*<*)
apply(rule iffI)
apply (auto elim: WTs.cases)
done
(*>*)

lemma [iff]: "(P,E  (e#es) [::] Ts) =
  (U Us. Ts = U#Us  P,E  e :: U  P,E  es [::] Us)"
(*<*)
apply(rule iffI)
apply (auto elim: WTs.cases)
done
(*>*)

lemma [iff]: "Ts. (P,E  es1 @ es2 [::] Ts) =
  (Ts1 Ts2. Ts = Ts1 @ Ts2  P,E  es1 [::] Ts1  P,E  es2[::]Ts2)"
(*<*)
apply(induct es1 type:list)
 apply simp
apply clarsimp
apply(erule thin_rl)
apply (rule iffI)
 apply clarsimp
 apply(rule exI)+
 apply(rule conjI)
  prefer 2 apply blast
 apply simp
apply fastforce
done
(*>*)

lemma [iff]: "P,E  Val v :: T = (typeof v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

lemma [iff]: "P,E  Var V :: T = (E V = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

lemma [iff]: "P,E  e1;;e2 :: T2 = (T1. P,E  e1::T1  P,E  e2::T2)"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

lemma [iff]: "(P,E  {V:T; e} :: T') = (is_type P T  P,E(VT)  e :: T')"
(*<*)
apply(rule iffI)
apply (auto elim: WT.cases)
done
(*>*)

(*<*)
inductive_cases WT_elim_cases[elim!]:
  "P,E  V :=e :: T"
  "P,E  if (e) e1 else e2 :: T"
  "P,E  while (e) c :: T"
  "P,E  throw e :: T"
  "P,E  try e1 catch(C V) e2 :: T"
  "P,E  Cast D e :: T"
  "P,E  aF{D} :: T"
  "P,E  aF{D} := v :: T"
  "P,E  e1 «bop» e2 :: T"
  "P,E  new C :: T"
  "P,E  eM(ps) :: T"
(*>*)


lemma wt_env_mono:
  "P,E  e :: T  (E'. E m E'  P,E'  e :: T)" and 
  "P,E  es [::] Ts  (E'. E m E'  P,E'  es [::] Ts)"
(*<*)
apply(induct rule: WT_WTs_inducts)
apply(simp add: WTNew)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOpEq)
apply(fastforce simp: WTBinOpAdd)
apply(force simp:map_le_def)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply(fastforce simp: WTCall)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(simp add: WTNil)
apply(simp add: WTCons)
done
(*>*)


lemma WT_fv: "P,E  e :: T  fv e  dom E"
and "P,E  es [::] Ts  fvs es  dom E"
(*<*)
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done

end
(*>*)

Theory WellTypeRT

(*  Title:      Jinja/J/WellTypeRT.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Runtime Well-typedness›

theory WellTypeRT
imports WellType
begin

inductive
  WTrt :: "J_prog  heap  env  expr  ty  bool"
  and WTrts :: "J_prog  heap  env  expr list  ty list  bool"
  and WTrt2 :: "[J_prog,env,heap,expr,ty]  bool"
        ("_,_,_  _ : _"   [51,51,51]50)
  and WTrts2 :: "[J_prog,env,heap,expr list, ty list]  bool"
        ("_,_,_  _ [:] _" [51,51,51]50)
  for P :: J_prog and h :: heap
where
  
  "P,E,h  e : T  WTrt P h E e T"
| "P,E,h  es[:]Ts  WTrts P h E es Ts"

| WTrtNew:
  "is_class P C  
  P,E,h  new C : Class C"

| WTrtCast:
  " P,E,h  e : T; is_refT T; is_class P C 
   P,E,h  Cast C e : Class C"

| WTrtVal:
  "typeofh v = Some T 
  P,E,h  Val v : T"

| WTrtVar:
  "E V = Some T  
  P,E,h  Var V : T"
(*
WTrtBinOp:
  "⟦ P,E,h ⊢ e1 : T1;  P,E,h ⊢ e2 : T2;
    case bop of Eq ⇒ T = Boolean
              | Add ⇒ T1 = Integer ∧ T2 = Integer ∧ T = Integer ⟧
   ⟹ P,E,h ⊢ e1 «bop» e2 : T"
*)
| WTrtBinOpEq:
  " P,E,h  e1 : T1;  P,E,h  e2 : T2 
   P,E,h  e1 «Eq» e2 : Boolean"

| WTrtBinOpAdd:
  " P,E,h  e1 : Integer;  P,E,h  e2 : Integer 
   P,E,h  e1 «Add» e2 : Integer"

| WTrtLAss:
  " E V = Some T;  P,E,h  e : T';  P  T'  T 
    P,E,h  V:=e : Void"

| WTrtFAcc:
  " P,E,h  e : Class C; P  C has F:T in D  
  P,E,h  eF{D} : T"

| WTrtFAccNT:
  "P,E,h  e : NT 
  P,E,h  eF{D} : T"

| WTrtFAss:
  " P,E,h  e1 : Class C;  P  C has F:T in D; P,E,h  e2 : T2;  P  T2  T 
   P,E,h  e1F{D}:=e2 : Void"

| WTrtFAssNT:
  " P,E,h  e1:NT; P,E,h  e2 : T2 
   P,E,h  e1F{D}:=e2 : Void"

| WTrtCall:
  " P,E,h  e : Class C; P  C sees M:Ts  T = (pns,body) in D;
     P,E,h  es [:] Ts'; P  Ts' [≤] Ts 
   P,E,h  eM(es) : T"

| WTrtCallNT:
  " P,E,h  e : NT; P,E,h  es [:] Ts 
   P,E,h  eM(es) : T"

| WTrtBlock:
  "P,E(VT),h  e : T'  
  P,E,h  {V:T; e} : T'"

| WTrtSeq:
  " P,E,h  e1:T1;  P,E,h  e2:T2 
   P,E,h  e1;;e2 : T2"

| WTrtCond:
  " P,E,h  e : Boolean;  P,E,h  e1:T1;  P,E,h  e2:T2;
     P  T1  T2  P  T2  T1; P  T1  T2  T = T2; P  T2  T1  T = T1 
   P,E,h  if (e) e1 else e2 : T"

| WTrtWhile:
  " P,E,h  e : Boolean;  P,E,h  c:T 
    P,E,h  while(e) c : Void"

| WTrtThrow:
  " P,E,h  e : Tr; is_refT Tr  
  P,E,h  throw e : T"

| WTrtTry:
  " P,E,h  e1 : T1;  P,E(V  Class C),h  e2 : T2; P  T1  T2 
   P,E,h  try e1 catch(C V) e2 : T2"

― ‹well-typed expression lists›

| WTrtNil:
  "P,E,h  [] [:] []"

| WTrtCons:
  " P,E,h  e : T;  P,E,h  es [:] Ts 
    P,E,h  e#es [:] T#Ts"

(*<*)
declare WTrt_WTrts.intros[intro!] WTrtNil[iff]
declare
  WTrtFAcc[rule del] WTrtFAccNT[rule del]
  WTrtFAss[rule del] WTrtFAssNT[rule del]
  WTrtCall[rule del] WTrtCallNT[rule del]

lemmas WTrt_induct = WTrt_WTrts.induct [split_format (complete)]
  and WTrt_inducts = WTrt_WTrts.inducts [split_format (complete)]
(*>*)


subsection‹Easy consequences›

lemma [iff]: "(P,E,h  [] [:] Ts) = (Ts = [])"
(*<*)
apply(rule iffI)
apply (auto elim: WTrts.cases)
done
(*>*)

lemma [iff]: "(P,E,h  e#es [:] T#Ts) = (P,E,h  e : T  P,E,h  es [:] Ts)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrts.cases)
done
(*>*)

lemma [iff]: "(P,E,h  (e#es) [:] Ts) =
  (U Us. Ts = U#Us  P,E,h  e : U  P,E,h  es [:] Us)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrts.cases)
done
(*>*)

lemma [simp]: "Ts. (P,E,h  es1 @ es2 [:] Ts) =
  (Ts1 Ts2. Ts = Ts1 @ Ts2  P,E,h  es1 [:] Ts1 & P,E,h  es2[:]Ts2)"
(*<*)
apply(induct_tac es1)
 apply simp
apply clarsimp
apply(erule thin_rl)
apply (rule iffI)
 apply clarsimp
 apply(rule exI)+
 apply(rule conjI)
  prefer 2 apply blast
 apply simp
apply fastforce
done
(*>*)

lemma [iff]: "P,E,h  Val v : T = (typeofh v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
(*>*)

lemma [iff]: "P,E,h  Var v : T = (E v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
(*>*)

lemma [iff]: "P,E,h  e1;;e2 : T2 = (T1. P,E,h  e1:T1  P,E,h  e2:T2)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
(*>*)

lemma [iff]: "P,E,h  {V:T; e} : T'  =  (P,E(VT),h  e : T')"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
(*>*)
(*<*)
inductive_cases WTrt_elim_cases[elim!]:
  "P,E,h  v :=e : T"
  "P,E,h  if (e) e1 else e2 : T"
  "P,E,h  while(e) c : T"
  "P,E,h  throw e : T"
  "P,E,h  try e1 catch(C V) e2 : T"
  "P,E,h  Cast D e : T"
  "P,E,h  eF{D} : T"
  "P,E,h  eF{D} := v : T"
  "P,E,h  e1 «bop» e2 : T"
  "P,E,h  new C : T"
  "P,E,h  eM{D}(es) : T"
(*>*)

subsection‹Some interesting lemmas›

lemma WTrts_Val[simp]:
 "Ts. (P,E,h  map Val vs [:] Ts) = (map (typeofh) vs = map Some Ts)"
(*<*)
apply(induct vs)
 apply simp
apply(case_tac Ts)
 apply simp
apply simp
done
(*>*)


lemma WTrts_same_length: "Ts. P,E,h  es [:] Ts  length es = length Ts"
(*<*)by(induct es type:list)auto(*>*)


lemma WTrt_env_mono:
  "P,E,h  e : T  (E'. E m E'  P,E',h  e : T)" and
  "P,E,h  es [:] Ts  (E'. E m E'  P,E',h  es [:] Ts)"
(*<*)
apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtVal)
apply(simp add: WTrtVar map_le_def dom_def)
apply(fastforce simp add: WTrtBinOpEq)
apply(fastforce simp add: WTrtBinOpAdd)
apply(force simp: map_le_def)
apply(fastforce simp: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
apply(fastforce simp: map_le_def)
apply(fastforce)
apply(fastforce simp: WTrtSeq)
apply(fastforce simp: WTrtWhile)
apply(fastforce simp: WTrtThrow)
apply(auto simp: WTrtTry map_le_def dom_def)
done
(*>*)


lemma WTrt_hext_mono: "P,E,h  e : T  h  h'  P,E,h'  e : T"
and WTrts_hext_mono: "P,E,h  es [:] Ts  h  h'  P,E,h'  es [:] Ts"
(*<*)
apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtVal dest:hext_typeof_mono)
apply(simp add: WTrtVar)
apply(fastforce simp add: WTrtBinOpEq)
apply(fastforce simp add: WTrtBinOpAdd)
apply(fastforce simp add: WTrtLAss)
apply(fast intro: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce)
apply(fastforce simp add: WTrtSeq)
apply(fastforce simp add: WTrtCond)
apply(fastforce simp add: WTrtWhile)
apply(fastforce simp add: WTrtThrow)
apply(fastforce simp: WTrtTry)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
done
(*>*)


lemma WT_implies_WTrt: "P,E  e :: T  P,E,h  e : T"
and WTs_implies_WTrts: "P,E  es [::] Ts  P,E,h  es [:] Ts"
(*<*)
apply(induct rule: WT_WTs_inducts)
apply fast
apply (fast)
apply(fastforce dest:typeof_lit_typeof)
apply(simp)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce simp: WTrtFAcc has_visible_field)
apply(fastforce simp: WTrtFAss dest: has_visible_field)
apply(fastforce simp: WTrtCall)
apply(fastforce)
apply(fastforce)
apply(fastforce simp: WTrtCond)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(simp)
apply(simp)
done
(*>*)


end

Theory DefAss

(*  Title:      Jinja/DefAss.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Definite assignment›

theory DefAss imports BigStep begin

subsection "Hypersets"

type_synonym 'a hyperset = "'a set option"

definition hyperUn :: "'a hyperset  'a hyperset  'a hyperset"   (infixl "" 65)
where
  "A  B    case A of None  None
                 | A  (case B of None  None | B  A  B)"

definition hyperInt :: "'a hyperset  'a hyperset  'a hyperset"   (infixl "" 70)
where
  "A  B    case A of None  B
                 | A  (case B of None  A | B  A  B)"

definition hyperDiff1 :: "'a hyperset  'a  'a hyperset"   (infixl "" 65)
where
  "A  a    case A of None  None | A  A - {a}"

definition hyper_isin :: "'a  'a hyperset  bool"   (infix "∈∈" 50)
where
  "a ∈∈ A    case A of None  True | A  a  A"

definition hyper_subset :: "'a hyperset  'a hyperset  bool"   (infix "" 50)
where
  "A  B    case B of None  True
                 | B  (case A of None  False | A  A  B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "{}  A = A    A  {} = A"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "A  B = A  B  A  a = A - {a}"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "None  A = None  A  None = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "a ∈∈ None  None  a = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyperUn_assoc: "(A  B)  C = A  (B  C)"
(*<*)by(simp add:hyperset_defs Un_assoc)(*>*)

lemma hyper_insert_comm: "A  {a} = {a}  A  A  ({a}  B) = {a}  (A  B)"
(*<*)by(simp add:hyperset_defs)(*>*)


subsection "Definite assignment"

primrec
  𝒜  :: "'a exp  'a hyperset"
  and 𝒜s :: "'a exp list  'a hyperset"
where
  "𝒜 (new C) = {}"
| "𝒜 (Cast C e) = 𝒜 e"
| "𝒜 (Val v) = {}"
| "𝒜 (e1 «bop» e2) = 𝒜 e1  𝒜 e2"
| "𝒜 (Var V) = {}"
| "𝒜 (LAss V e) = {V}  𝒜 e"
| "𝒜 (eF{D}) = 𝒜 e"
| "𝒜 (e1F{D}:=e2) = 𝒜 e1  𝒜 e2"
| "𝒜 (eM(es)) = 𝒜 e  𝒜s es"
| "𝒜 ({V:T; e}) = 𝒜 e  V"
| "𝒜 (e1;;e2) = 𝒜 e1  𝒜 e2"
| "𝒜 (if (e) e1 else e2) =  𝒜 e  (𝒜 e1  𝒜 e2)"
| "𝒜 (while (b) e) = 𝒜 b"
| "𝒜 (throw e) = None"
| "𝒜 (try e1 catch(C V) e2) = 𝒜 e1  (𝒜 e2  V)"

| "𝒜s ([]) = {}"
| "𝒜s (e#es) = 𝒜 e  𝒜s es"

primrec
  𝒟  :: "'a exp  'a hyperset  bool"
  and 𝒟s :: "'a exp list  'a hyperset  bool"
where
  "𝒟 (new C) A = True"
| "𝒟 (Cast C e) A = 𝒟 e A"
| "𝒟 (Val v) A = True"
| "𝒟 (e1 «bop» e2) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1))"
| "𝒟 (Var V) A = (V ∈∈ A)"
| "𝒟 (LAss V e) A = 𝒟 e A"
| "𝒟 (eF{D}) A = 𝒟 e A"
| "𝒟 (e1F{D}:=e2) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1))"
| "𝒟 (eM(es)) A = (𝒟 e A  𝒟s es (A  𝒜 e))"
| "𝒟 ({V:T; e}) A = 𝒟 e (A  V)"
| "𝒟 (e1;;e2) A = (𝒟 e1 A  𝒟 e2 (A  𝒜 e1))"
| "𝒟 (if (e) e1 else e2) A =
  (𝒟 e A  𝒟 e1 (A  𝒜 e)  𝒟 e2 (A  𝒜 e))"
| "𝒟 (while (e) c) A = (𝒟 e A  𝒟 c (A  𝒜 e))"
| "𝒟 (throw e) A = 𝒟 e A"
| "𝒟 (try e1 catch(C V) e2) A = (𝒟 e1 A  𝒟 e2 (A  {V}))"

| "𝒟s ([]) A = True"
| "𝒟s (e#es) A = (𝒟 e A  𝒟s es (A  𝒜 e))"

lemma As_map_Val[simp]: "𝒜s (map Val vs) = {}"
(*<*)by (induct vs) simp_all(*>*)

lemma D_append[iff]: "A. 𝒟s (es @ es') A = (𝒟s es A  𝒟s es' (A  𝒜s es))"
(*<*)by (induct es type:list) (auto simp:hyperUn_assoc)(*>*)


lemma A_fv: "A. 𝒜 e = A  A  fv e"
and  "A. 𝒜s es = A  A  fvs es"
(*<*)
apply(induct e and es rule: 𝒜.induct 𝒜s.induct)
apply (simp_all add:hyperset_defs)
apply blast+
done
(*>*)


lemma sqUn_lem: "A  A'  A  B  A'  B"
(*<*)by(simp add:hyperset_defs) blast(*>*)

lemma diff_lem: "A  A'  A  b  A'  b"
(*<*)by(simp add:hyperset_defs) blast(*>*)

(* This order of the premises avoids looping of the simplifier *)
lemma D_mono: "A A'. A  A'  𝒟 e A  𝒟 (e::'a exp) A'"
and Ds_mono: "A A'. A  A'  𝒟s es A  𝒟s (es::'a exp list) A'"
(*<*)
apply(induct e and es rule: 𝒟.induct 𝒟s.induct)
apply simp
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply (fastforce simp add:hyperset_defs)
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:diff_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
done
(*>*)

(* And this is the order of premises preferred during application: *)
lemma D_mono': "𝒟 e A  A  A'  𝒟 e A'"
and Ds_mono': "𝒟s es A  A  A'  𝒟s es A'"
(*<*)by(blast intro:D_mono, blast intro:Ds_mono)(*>*)

(*
text{* @{term"𝒜"} is sound w.r.t.\ the big step semantics: it
computes a conservative approximation of the variables actually
assigned to. *}

lemma "P ⊢ ⟨e,(h0,l0)⟩ ⇒ ⟨e',(h1,l1)⟩ ⟹ (!!A. 𝒜 e = ⌊A⌋ ⟹ A ⊆ dom l1)"
and "P ⊢ ⟨es,(h0,l0)⟩ [⇒] ⟨es',(h1,l1)⟩ ⟹ (!!A. 𝒜s es = ⌊A⌋ ⟹ A ⊆ dom l1)"

proof (induct rule:eval_evals_induct)
  case LAss thus ?case apply(simp add:dom_def hyperset_defs) apply blast
apply blast
next
  case FAss thus ?case by simp (blast dest:eval_lcl_incr)
next
  case BinOp thus ?case by simp (blast dest:eval_lcl_incr)
next
  case Call thus  ?case by simp (blast dest:evals_lcl_incr)
next
  case Cons thus ?case by simp (blast dest:evals_lcl_incr)
next
  case Block thus ?case by(simp del: fun_upd_apply) blast
next
  case Seq thus ?case by simp (blast dest:eval_lcl_incr)
next
  case CondT thus ?case by simp (blast dest:eval_lcl_incr)
next
  case CondF thus ?case by simp (blast dest:eval_lcl_incr)
next
  case Try thus ?case by(fastforce dest!: eval_lcl_incr)
next
  case TryCatch thus ?case by(fastforce dest!: eval_lcl_incr)
qed auto
*)
end

Theory Conform

(*  Title:      Jinja/J/Conform.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Conformance Relations for Type Soundness Proofs›

theory Conform
imports Exceptions
begin

definition conf :: "'m prog  heap  val  ty  bool"   ("_,_  _ :≤ _"  [51,51,51,51] 50)
where
  "P,h  v :≤ T  
  T'. typeofh v = Some T'  P  T'  T"

definition oconf :: "'m prog  heap  obj  bool"   ("_,_  _ " [51,51,51] 50)
where
  "P,h  obj   
  let (C,fs) = obj in F D T. P  C has F:T in D 
  (v. fs(F,D) = Some v  P,h  v :≤ T)"

definition hconf :: "'m prog  heap  bool"  ("_  _ " [51,51] 50)
where
  "P  h   
  (a obj. h a = Some obj  P,h  obj )  preallocated h"

definition lconf :: "'m prog  heap  (vname  val)  (vname  ty)  bool"   ("_,_  _ '(:≤') _" [51,51,51,51] 50)
where
  "P,h  l (:≤) E  
  V v. l V = Some v  (T. E V = Some T  P,h  v :≤ T)"

abbreviation
  confs :: "'m prog  heap  val list  ty list  bool" 
             ("_,_  _ [:≤] _" [51,51,51,51] 50) where
  "P,h  vs [:≤] Ts  list_all2 (conf P h) vs Ts"


subsection‹Value conformance :≤›

lemma conf_Null [simp]: "P,h  Null :≤ T  =  P  NT  T"
(*<*)
apply (unfold conf_def)
apply (simp (no_asm))
done
(*>*)

lemma typeof_conf[simp]: "typeofh v = Some T  P,h  v :≤ T"
(*<*)
apply (unfold conf_def)
apply (induct v)
apply auto
done
(*>*)

lemma typeof_lit_conf[simp]: "typeof v = Some T  P,h  v :≤ T"
(*<*)by (rule typeof_conf[OF typeof_lit_typeof])(*>*)

lemma defval_conf[simp]: "P,h  default_val T :≤ T"
(*<*)
apply (unfold conf_def)
apply (cases T)
apply auto
done
(*>*)

lemma conf_upd_obj: "h a = Some(C,fs)  (P,h(a(C,fs'))  x :≤ T) = (P,h  x :≤ T)"
(*<*)
apply (unfold conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
done
(*>*)

lemma conf_widen: "P,h  v :≤ T  P  T  T'  P,h  v :≤ T'"
(*<*)
apply (unfold conf_def)
apply (induct v)
apply (auto intro: widen_trans)
done
(*>*)

lemma conf_hext: "h  h'  P,h  v :≤ T  P,h'  v :≤ T"
(*<*)
apply (unfold conf_def)
apply (induct v)
apply (auto dest: hext_objD)
done
(*>*)

lemma conf_ClassD: "P,h  v :≤ Class C 
  v = Null  (a obj T. v = Addr a   h a = Some obj  obj_ty obj = T   P  T  Class C)"
(*<*)
apply (unfold conf_def)
apply(induct "v")
apply(auto)
done
(*>*)

lemma conf_NT [iff]: "P,h  v :≤ NT = (v = Null)"
(*<*)by (auto simp add: conf_def)(*>*)

lemma non_npD: " v  Null; P,h  v :≤ Class C 
   a C' fs. v = Addr a  h a = Some(C',fs)  P  C' * C"
(*<*)
apply (drule conf_ClassD)
apply auto
done
(*>*)


subsection‹Value list conformance [:≤]›

lemma confs_widens [trans]: "P,h  vs [:≤] Ts; P  Ts [≤] Ts'  P,h  vs [:≤] Ts'"
(*<*)
  apply (rule list_all2_trans)
    apply (rule conf_widen, assumption, assumption)
   apply assumption
  apply assumption
  done
(*>*)

lemma confs_rev: "P,h  rev s [:≤] t = (P,h  s [:≤] rev t)"
(*<*)
  apply rule
  apply (rule subst [OF list_all2_rev])
  apply simp
  apply (rule subst [OF list_all2_rev])
  apply simp
  done
(*>*)

lemma confs_conv_map:
  "Ts'. P,h  vs [:≤] Ts' = (Ts. map typeofh vs = map Some Ts  P  Ts [≤] Ts')"
(*<*)
apply(induct vs)
 apply simp
apply(case_tac Ts')
apply(auto simp add:conf_def)
done
(*>*)

lemma confs_hext: "P,h  vs [:≤] Ts  h  h'  P,h'  vs [:≤] Ts"
(*<*)by (erule list_all2_mono, erule conf_hext, assumption)(*>*)

lemma confs_Cons2: "P,h  xs [:≤] y#ys = (z zs. xs = z#zs  P,h  z :≤ y  P,h  zs [:≤] ys)"
(*<*)by (rule list_all2_Cons2)(*>*)


subsection "Object conformance"

lemma oconf_hext: "P,h  obj   h  h'  P,h'  obj "
(*<*)
apply (unfold oconf_def)
apply (fastforce elim:conf_hext)
done
(*>*)

lemma oconf_init_fields:
 "P  C has_fields FDTs  P,h  (C, init_fields FDTs) "
by(fastforce simp add: has_field_def oconf_def init_fields_def map_of_map
            dest: has_fields_fun)

lemma oconf_fupd [intro?]:
  " P  C has F:T in D; P,h  v :≤ T; P,h  (C,fs)   
   P,h  (C, fs((F,D)v)) "
(*<*)
  apply (unfold oconf_def has_field_def)
  apply clarsimp
  apply (drule (1) has_fields_fun)
  apply (auto simp add: fun_upd_apply)
  done                                    
(*>*)

(*<*)
lemmas oconf_new = oconf_hext [OF _ hext_new]
lemmas oconf_upd_obj = oconf_hext [OF _ hext_upd_obj]
(*>*)

subsection "Heap conformance"

lemma hconfD: " P  h ; h a = Some obj   P,h  obj "
(*<*)
apply (unfold hconf_def)
apply (fast)
done
(*>*)

lemma hconf_new: " P  h ; h a = None; P,h  obj    P  h(aobj) "
(*<*)by (unfold hconf_def) (auto intro: oconf_new preallocated_new)(*>*)

lemma hconf_upd_obj: " P  h; h a = Some(C,fs); P,h  (C,fs')   P  h(a(C,fs'))"
(*<*)by (unfold hconf_def) (auto intro: oconf_upd_obj preallocated_upd_obj)(*>*)


subsection "Local variable conformance"

lemma lconf_hext: " P,h  l (:≤) E; h  h'   P,h'  l (:≤) E"
(*<*)
apply (unfold lconf_def)
apply  (fast elim: conf_hext)
done
(*>*)

lemma lconf_upd:
  " P,h  l (:≤) E; P,h  v :≤ T; E V = Some T   P,h  l(Vv) (:≤) E"
(*<*)
apply (unfold lconf_def)
apply auto
done
(*>*)

lemma lconf_empty[iff]: "P,h  Map.empty (:≤) E"
(*<*)by(simp add:lconf_def)(*>*)

lemma lconf_upd2: "P,h  l (:≤) E; P,h  v :≤ T  P,h  l(Vv) (:≤) E(VT)"
(*<*)by(simp add:lconf_def)(*>*)


end

Theory Progress

(*  Title:      Jinja/J/SmallProgress.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Progress of Small Step Semantics›

theory Progress
imports Equivalence WellTypeRT DefAss "../Common/Conform"
begin

lemma final_addrE:
  " P,E,h  e : Class C; final e;
    a. e = addr a  R;
    a. e = Throw a  R   R"
(*<*)by(auto simp:final_def)(*>*)


lemma finalRefE:
 " P,E,h  e : T; is_refT T; final e;
   e = null  R;
   a C.  e = addr a; T = Class C   R;
   a. e = Throw a  R   R"
(*<*)by(auto simp:final_def is_refT_def)(*>*)


text‹Derivation of new induction scheme for well typing:›

inductive
  WTrt' :: "[J_prog,heap,env,expr,ty]  bool"
  and WTrts' :: "[J_prog,heap,env,expr list, ty list]  bool"
  and WTrt2' :: "[J_prog,env,heap,expr,ty]  bool"
        ("_,_,_  _ :'' _"   [51,51,51]50)
  and WTrts2' :: "[J_prog,env,heap,expr list, ty list]  bool"
        ("_,_,_  _ [:''] _" [51,51,51]50)
  for P :: J_prog and h :: heap
where
  "P,E,h  e :' T  WTrt' P h E e T"
| "P,E,h  es [:'] Ts  WTrts' P h E es Ts"

| "is_class P C    P,E,h  new C :' Class C"
| " P,E,h  e :' T; is_refT T; is_class P C 
   P,E,h  Cast C e :' Class C"
| "typeofh v = Some T  P,E,h  Val v :' T"
| "E v = Some T    P,E,h  Var v :' T"
| " P,E,h  e1 :' T1;  P,E,h  e2 :' T2 
   P,E,h  e1 «Eq» e2 :' Boolean"
| " P,E,h  e1 :' Integer;  P,E,h  e2 :' Integer 
   P,E,h  e1 «Add» e2 :' Integer"
| " P,E,h  Var V :' T;  P,E,h  e :' T';  P  T'  T ⌦‹V ≠ This› 
   P,E,h  V:=e :' Void"
| " P,E,h  e :' Class C; P  C has F:T in D   P,E,h  eF{D} :' T"
| "P,E,h  e :' NT  P,E,h  eF{D} :' T"
| " P,E,h  e1 :' Class C;  P  C has F:T in D;
    P,E,h  e2 :' T2;  P  T2  T 
   P,E,h  e1F{D}:=e2 :' Void"
| " P,E,h  e1:'NT; P,E,h  e2 :' T2   P,E,h  e1F{D}:=e2 :' Void"
| " P,E,h  e :' Class C; P  C sees M:Ts  T = (pns,body) in D;
    P,E,h  es [:'] Ts'; P  Ts' [≤] Ts 
   P,E,h  eM(es) :' T"
| " P,E,h  e :' NT; P,E,h  es [:'] Ts   P,E,h  eM(es) :' T"
| "P,E,h  [] [:'] []"
| " P,E,h  e :' T;  P,E,h  es [:'] Ts    P,E,h  e#es [:'] T#Ts"
| " typeofh v = Some T1; P  T1  T; P,E(VT),h  e2 :' T2 
    P,E,h  {V:T := Val v; e2} :' T2"
| " P,E(VT),h  e :' T'; ¬ assigned V e    P,E,h  {V:T; e} :' T'"
| " P,E,h  e1:' T1;  P,E,h  e2:'T2     P,E,h  e1;;e2 :' T2"
| " P,E,h  e :' Boolean;  P,E,h  e1:' T1;  P,E,h  e2:' T2;
    P  T1  T2  P  T2  T1;
    P  T1  T2  T = T2; P  T2  T1  T = T1 
   P,E,h  if (e) e1 else e2 :' T"
(*
 "⟦ P,E,h ⊢ e :' Boolean;  P,E,h ⊢ e1:' T1;  P,E,h ⊢ e2:' T2; P ⊢ T1 ≤ T2 ⟧
  ⟹ P,E,h ⊢ if (e) e1 else e2 :' T2"
 "⟦ P,E,h ⊢ e :' Boolean;  P,E,h ⊢ e1:' T1;  P,E,h ⊢ e2:' T2; P ⊢ T2 ≤ T1 ⟧
  ⟹ P,E,h ⊢ if (e) e1 else e2 :' T1"
*)
| " P,E,h  e :' Boolean;  P,E,h  c:' T 
    P,E,h  while(e) c :' Void"
| " P,E,h  e :' Tr; is_refT Tr     P,E,h  throw e :' T"
| " P,E,h  e1 :' T1;  P,E(V  Class C),h  e2 :' T2; P  T1  T2 
   P,E,h  try e1 catch(C V) e2 :' T2"

(*<*)
lemmas WTrt'_induct = WTrt'_WTrts'.induct [split_format (complete)]
  and WTrt'_inducts = WTrt'_WTrts'.inducts [split_format (complete)]

inductive_cases WTrt'_elim_cases[elim!]:
  "P,E,h  V :=e :' T"
(*>*)

lemma [iff]: "P,E,h  e1;;e2 :' T2 = (T1. P,E,h  e1:' T1  P,E,h  e2:' T2)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)

lemma [iff]: "P,E,h  Val v :' T = (typeofh v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)

lemma [iff]: "P,E,h  Var v :' T = (E v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)


lemma wt_wt': "P,E,h  e : T  P,E,h  e :' T"
and wts_wts': "P,E,h  es [:] Ts  P,E,h  es [:'] Ts"
(*<*)
apply (induct rule:WTrt_inducts)
prefer 14
apply(case_tac "assigned V e")
apply(clarsimp simp add:fun_upd_same assigned_def simp del:fun_upd_apply)
apply(erule (2) WTrt'_WTrts'.intros)
apply(erule (1) WTrt'_WTrts'.intros)
apply(blast intro:WTrt'_WTrts'.intros)+
done
(*>*)


lemma wt'_wt: "P,E,h  e :' T  P,E,h  e : T"
and wts'_wts: "P,E,h  es [:'] Ts  P,E,h  es [:] Ts"
(*<*)
apply (induct rule:WTrt'_inducts)
prefer 16
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply simp
apply(erule (2) WTrt_WTrts.intros)
apply(blast intro:WTrt_WTrts.intros)+
done
(*>*)


corollary wt'_iff_wt: "(P,E,h  e :' T) = (P,E,h  e : T)"
(*<*)by(blast intro:wt_wt' wt'_wt)(*>*)


corollary wts'_iff_wts: "(P,E,h  es [:'] Ts) = (P,E,h  es [:] Ts)"
(*<*)by(blast intro:wts_wts' wts'_wts)(*>*)

(*<*)
lemmas WTrt_inducts2 = WTrt'_inducts [unfolded wt'_iff_wt wts'_iff_wts,
 case_names WTrtNew WTrtCast WTrtVal WTrtVar WTrtBinOpEq WTrtBinOpAdd WTrtLAss WTrtFAcc WTrtFAccNT WTrtFAss
 WTrtFAssNT WTrtCall WTrtCallNT WTrtNil WTrtCons WTrtInitBlock WTrtBlock WTrtSeq WTrtCond
 WTrtWhile WTrtThrow WTrtTry, consumes 1]
(*>*)

theorem assumes wf: "wwf_J_prog P" and hconf: "P  h "
shows progress: "P,E,h  e : T 
 (l.  𝒟 e dom l; ¬ final e   e' s'. P  e,(h,l)  e',s')"
and "P,E,h  es [:] Ts 
 (l.  𝒟s es dom l; ¬ finals es   es' s'. P  es,(h,l) [→] es',s')"
(*<*)
proof (induct rule:WTrt_inducts2)
  case WTrtNew
  show ?case
  proof cases
    assume "a. h a = None"
    with assms WTrtNew show ?thesis
      by (fastforce del:exE intro!:RedNew simp add:new_Addr_def
                   elim!:wf_Fields_Ex[THEN exE])
  next
    assume "¬(a. h a = None)"
    with assms WTrtNew show ?thesis
      by(fastforce intro:RedNewFail simp add:new_Addr_def)
  qed
next
  case (WTrtCast E e T C)
  have wte: "P,E,h  e : T" and ref: "is_refT T"
   and IH: "l. 𝒟 e dom l; ¬ final e
                 e' s'. P  e,(h,l)  e',s'"
   and D: "𝒟 (Cast C e) dom l" by fact+
  from D have De: "𝒟 e dom l" by auto
  show ?case
  proof cases
    assume "final e"
    with wte ref show ?thesis
    proof (rule finalRefE)
      assume "e = null" thus ?case by(fastforce intro:RedCastNull)
    next
      fix D a assume A: "T = Class D" "e = addr a"
      show ?thesis
      proof cases
        assume "P  D * C"
        thus ?thesis using A wte by(fastforce intro:RedCast)
      next
        assume "¬ P  D * C"
        thus ?thesis using A wte by(force intro!:RedCastFail)
      qed
    next
      fix a assume "e = Throw a"
      thus ?thesis by(blast intro!:red_reds.CastThrow)
    qed
  next
    assume nf: "¬ final e"
    from IH[OF De nf] show ?thesis by (blast intro:CastRed)
  qed
next
  case WTrtVal thus ?case by(simp add:final_def)
next
  case WTrtVar thus ?case by(fastforce intro:RedVar simp:hyper_isin_def)
next
  case (WTrtBinOpEq E e1 T1 e2 T2)
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
    proof (rule finalE)
      fix v1 assume [simp]: "e1 = Val v1"
      show ?thesis
      proof cases
        assume "final e2"
        thus ?thesis
        proof (rule finalE)
          fix v2 assume "e2 = Val v2"
          thus ?thesis using WTrtBinOpEq by(fastforce intro:RedBinOp)
        next
          fix a assume "e2 = Throw a"
          thus ?thesis by(auto intro:red_reds.BinOpThrow2)
        qed
      next
        assume "¬ final e2" with WTrtBinOpEq show ?thesis
          by simp (fast intro!:BinOpRed2)
      qed
    next
      fix a assume "e1 = Throw a"
      thus ?thesis by simp (fast intro:red_reds.BinOpThrow1)
    qed
  next
    assume "¬ final e1" with WTrtBinOpEq show ?thesis
      by simp (fast intro:BinOpRed1)
  qed
next
  case (WTrtBinOpAdd E e1 e2)
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
    proof (rule finalE)
      fix v1 assume [simp]: "e1 = Val v1"
      show ?thesis
      proof cases
        assume "final e2"
        thus ?thesis
        proof (rule finalE)
          fix v2 assume "e2 = Val v2"
          thus ?thesis using WTrtBinOpAdd by(fastforce intro:RedBinOp)
        next
          fix a assume "e2 = Throw a"
          thus ?thesis by(auto intro:red_reds.BinOpThrow2)
        qed
      next
        assume "¬ final e2" with WTrtBinOpAdd show ?thesis
          by simp (fast intro!:BinOpRed2)
      qed
    next
      fix a assume "e1 = Throw a"
      thus ?thesis by simp (fast intro:red_reds.BinOpThrow1)
    qed
  next
    assume "¬ final e1" with WTrtBinOpAdd show ?thesis
      by simp (fast intro:BinOpRed1)
  qed
next
  case (WTrtLAss E V T e T')
  show ?case
  proof cases
    assume "final e" with WTrtLAss show ?thesis
      by(auto simp:final_def intro!:RedLAss red_reds.LAssThrow)
  next
    assume "¬ final e" with WTrtLAss show ?thesis
      by simp (fast intro:LAssRed)
  qed
next
  case (WTrtFAcc E e C F T D)
  have wte: "P,E,h  e : Class C"
   and field: "P  C has F:T in D" by fact+
  show ?case
  proof cases
    assume "final e"
    with wte show ?thesis
    proof (rule final_addrE)
      fix a assume e: "e = addr a"
      with wte obtain fs where hp: "h a = Some(C,fs)" by auto
      with hconf have "P,h  (C,fs) " using hconf_def by fastforce
      then obtain v where "fs(F,D) = Some v" using field
        by(fastforce dest:has_fields_fun simp:oconf_def has_field_def)
      with hp e show ?thesis by(fastforce intro:RedFAcc)
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fastforce intro:red_reds.FAccThrow)
    qed
  next
    assume "¬ final e" with WTrtFAcc show ?thesis
      by(fastforce intro!:FAccRed)
  qed
next
  case (WTrtFAccNT E e F D T)
  show ?case
  proof cases
    assume "final e"  ― ‹@{term e} is @{term null} or @{term throw}›
    with WTrtFAccNT show ?thesis
      by(fastforce simp:final_def intro: RedFAccNull red_reds.FAccThrow)
  next
    assume "¬ final e" ― ‹@{term e} reduces by IH›
    with WTrtFAccNT show ?thesis by simp (fast intro:FAccRed)
  qed
next
  case (WTrtFAss E e1 C F T D e2 T2)
  have wte1: "P,E,h  e1 : Class C" by fact
  show ?case
  proof cases
    assume "final e1"
    with wte1 show ?thesis
    proof (rule final_addrE)
      fix a assume e1: "e1 = addr a"
      show ?thesis
      proof cases
        assume "final e2"
        thus ?thesis
        proof (rule finalE)
          fix v assume "e2 = Val v"
          thus ?thesis using e1 wte1 by(fastforce intro:RedFAss)
        next
          fix a assume "e2 = Throw a"
          thus ?thesis using e1 by(fastforce intro:red_reds.FAssThrow2)
        qed
      next
        assume "¬ final e2" with WTrtFAss e1 show ?thesis
          by simp (fast intro!:FAssRed2)
      qed
    next
      fix a assume "e1 = Throw a"
      thus ?thesis by(fastforce intro:red_reds.FAssThrow1)
    qed
  next
    assume "¬ final e1" with WTrtFAss show ?thesis
      by simp (blast intro!:FAssRed1)
  qed
next
  case (WTrtFAssNT E e1 e2 T2 F D)
  show ?case
  proof cases
    assume e1: "final e1"  ― ‹@{term e1} is @{term null} or @{term throw}›
    show ?thesis
    proof cases
      assume "final e2"  ― ‹@{term e2} is @{term Val} or @{term throw}›
      with WTrtFAssNT e1 show ?thesis
        by(fastforce simp:final_def intro: RedFAssNull red_reds.FAssThrow1 red_reds.FAssThrow2)
    next
      assume "¬ final e2" ― ‹@{term e2} reduces by IH›
      with WTrtFAssNT e1 show ?thesis
        by (fastforce  simp:final_def intro!:red_reds.FAssRed2 red_reds.FAssThrow1)
    qed
  next
    assume "¬ final e1" ― ‹@{term e1} reduces by IH›
    with WTrtFAssNT show ?thesis by (fastforce intro:FAssRed1)
  qed
next
  case (WTrtCall E e C M Ts T pns body D es Ts')
  have wte: "P,E,h  e : Class C"
   and "method": "P  C sees M:TsT = (pns,body) in D"
   and wtes: "P,E,h  es [:] Ts'"and sub: "P  Ts' [≤] Ts"
   and IHes: "l.
             𝒟s es dom l; ¬ finals es
              es' s'. P  es,(h,l) [→] es',s'"
   and D: "𝒟 (eM(es)) dom l" by fact+
  show ?case
  proof cases
    assume "final e"
    with wte show ?thesis
    proof (rule final_addrE)
      fix a assume e_addr: "e = addr a"
      show ?thesis
      proof cases
        assume es: "vs. es = map Val vs"
        from wte e_addr obtain fs where ha: "h a = Some(C,fs)" by auto
        show ?thesis
          using e_addr ha "method" WTrts_same_length[OF wtes] sub es sees_wf_mdecl[OF wf "method"]
          by (fastforce intro!: RedCall simp:list_all2_iff wf_mdecl_def)
      next
        assume "¬(vs. es = map Val vs)"
        hence not_all_Val: "¬(e  set es. v. e = Val v)"
          by(simp add:ex_map_conv)
        let ?ves = "takeWhile (λe. v. e = Val v) es"
        let ?rest = "dropWhile (λe. v. e = Val v) es"
        let ?ex = "hd ?rest" let ?rst = "tl ?rest"
        from not_all_Val have nonempty: "?rest  []" by auto
        hence es: "es = ?ves @ ?ex # ?rst" by simp
        have "e  set ?ves. v. e = Val v" by(fastforce dest:set_takeWhileD)
        then obtain vs where ves: "?ves = map Val vs"
          using ex_map_conv by blast
        show ?thesis
        proof cases
          assume "final ?ex"
          moreover from nonempty have "¬(v. ?ex = Val v)"
            by(auto simp:neq_Nil_conv simp del:dropWhile_eq_Nil_conv)
              (simp add:dropWhile_eq_Cons_conv)
          ultimately obtain b where ex_Throw: "?ex = Throw b"
            by(fast elim!:finalE)
          show ?thesis using e_addr es ex_Throw ves
            by(fastforce intro:CallThrowParams)
        next
          assume not_fin: "¬ final ?ex"
          have "finals es = finals(?ves @ ?ex # ?rst)" using es
            by(rule arg_cong)
          also have " = finals(?ex # ?rst)" using ves by simp
          finally have "finals es = finals(?ex # ?rst)" .
          hence "¬ finals es" using not_finals_ConsI[OF not_fin] by blast
          thus ?thesis using e_addr D IHes  by(fastforce intro!:CallParams)
        qed
      qed
    next
      fix a assume "e = Throw a"
      with WTrtCall.prems show ?thesis by(fast intro!:CallThrowObj)
    qed
  next
    assume "¬ final e"
    with WTrtCall show ?thesis by simp (blast intro!:CallObj)
  qed
next
  case (WTrtCallNT E e es Ts M T)
  show ?case
  proof cases
    assume "final e"
    moreover
    { fix v assume e: "e = Val v"
      hence "e = null" using WTrtCallNT by simp
      have ?case
      proof cases
        assume "finals es"
        moreover
        { fix vs assume "es = map Val vs"
          with WTrtCallNT e have ?thesis by(fastforce intro: RedCallNull) }
        moreover
        { fix vs a es' assume "es = map Val vs @ Throw a # es'"
          with WTrtCallNT e have ?thesis by(fastforce intro: CallThrowParams) }
        ultimately show ?thesis by(fastforce simp:finals_def)
      next
        assume "¬ finals es" ― ‹@{term es} reduces by IH›
        with WTrtCallNT e show ?thesis by(fastforce intro: CallParams)
      qed
    }
    moreover
    { fix a assume "e = Throw a"
      with WTrtCallNT have ?case by(fastforce intro: CallThrowObj) }
    ultimately show ?thesis by(fastforce simp:final_def)
  next
    assume "¬ final e" ― ‹@{term e} reduces by IH›
    with WTrtCallNT show ?thesis by (fastforce intro:CallObj)
  qed
next
  case WTrtNil thus ?case by simp
next
  case (WTrtCons E e T es Ts)
  have IHe: "l. 𝒟 e dom l; ¬ final e
                 e' s'. P  e,(h,l)  e',s'"
   and IHes: "l. 𝒟s es dom l; ¬ finals es
              es' s'. P  es,(h,l) [→] es',s'"
   and D: "𝒟s (e#es) dom l" and not_fins: "¬ finals(e # es)" by fact+
  have De: "𝒟 e dom l" and Des: "𝒟s es (dom l  𝒜 e)"
    using D by auto
  show ?case
  proof cases
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v assume e: "e = Val v"
      hence Des': "𝒟s es dom l" using De Des by auto
      have not_fins_tl: "¬ finals es" using not_fins e by simp
      show ?thesis using e IHes[OF Des' not_fins_tl]
        by (blast intro!:ListRed2)
    next
      fix a assume "e = Throw a"
      hence False using not_fins by simp
      thus ?thesis ..
    qed
  next
    assume "¬ final e"
    with IHe[OF De] show ?thesis by(fast intro!:ListRed1)
  qed
next
  case (WTrtInitBlock v T1 T E V e2 T2)
  have IH2: "l. 𝒟 e2 dom l; ¬ final e2
                   e' s'. P  e2,(h,l)  e',s'"
   and D: "𝒟 {V:T := Val v; e2} dom l" by fact+
  show ?case
  proof cases
    assume "final e2"
    then show ?thesis
    proof (rule finalE)
      fix v2 assume "e2 = Val v2"
      thus ?thesis by(fast intro:RedInitBlock)
    next
      fix a assume "e2 = Throw a"
      thus ?thesis by(fast intro:red_reds.InitBlockThrow)
    qed
  next
    assume not_fin2: "¬ final e2"
    from D have D2: "𝒟 e2 dom(l(Vv))" by (auto simp:hyperset_defs)
    from IH2[OF D2 not_fin2]
    obtain h' l' e' where red2: "P  e2,(h, l(Vv))  e',(h', l')"
      by auto
    from red_lcl_incr[OF red2] have "V  dom l'" by auto
    with red2 show ?thesis by(fastforce intro:InitBlockRed)
  qed
next
  case (WTrtBlock E V T e T')
  have IH: "l. 𝒟 e dom l; ¬ final e
                  e' s'. P  e,(h,l)  e',s'"
   and unass: "¬ assigned V e" and D: "𝒟 {V:T; e} dom l" by fact+
  show ?case
  proof cases
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v assume "e = Val v" thus ?thesis by(fast intro:RedBlock)
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fast intro:red_reds.BlockThrow)
    qed
  next
    assume not_fin: "¬ final e"
    from D have De: "𝒟 e dom(l(V:=None))" by(simp add:hyperset_defs)
    from IH[OF De not_fin]
    obtain h' l' e' where red: "P  e,(h,l(V:=None))  e',(h',l')"
      by auto
    show ?thesis
    proof (cases "l' V")
      assume "l' V = None"
      with red unass show ?thesis by(blast intro: BlockRedNone)
    next
      fix v assume "l' V = Some v"
      with red unass show ?thesis by(blast intro: BlockRedSome)
    qed
  qed
next
  case (WTrtSeq E e1 T1 e2 T2)
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
      by(fast elim:finalE intro:RedSeq red_reds.SeqThrow)
  next
    assume "¬ final e1" with WTrtSeq show ?thesis
      by simp (blast intro:SeqRed)
  qed
next
  case (WTrtCond E e e1 T1 e2 T2 T)
  have wt: "P,E,h  e : Boolean" by fact
  show ?case
  proof cases
    assume "final e"
    thus ?thesis
    proof (rule finalE)
      fix v assume val: "e = Val v"
      then obtain b where v: "v = Bool b" using wt by auto
      show ?thesis
      proof (cases b)
        case True with val v show ?thesis by(auto intro:RedCondT)
      next
        case False with val v show ?thesis by(auto intro:RedCondF)
      qed
    next
      fix a assume "e = Throw a"
      thus ?thesis by(fast intro:red_reds.CondThrow)
    qed
  next
    assume "¬ final e" with WTrtCond show ?thesis
      by simp (fast intro:CondRed)
  qed
next
  case WTrtWhile show ?case by(fast intro:RedWhile)
next
  case (WTrtThrow E e Tr T)
  show ?case
  proof cases
    assume "final e" ― ‹Then @{term e} must be @{term throw} or @{term null}›
    with WTrtThrow show ?thesis
      by(fastforce simp:final_def is_refT_def
                  intro:red_reds.ThrowThrow red_reds.RedThrowNull)
  next
    assume "¬ final e" ― ‹Then @{term e} must reduce›
    with WTrtThrow show ?thesis by simp (blast intro:ThrowRed)
  qed
next
  case (WTrtTry E e1 T1 V C e2 T2)
  have wt1: "P,E,h  e1 : T1" by fact
  show ?case
  proof cases
    assume "final e1"
    thus ?thesis
    proof (rule finalE)
      fix v assume "e1 = Val v"
      thus ?thesis by(fast intro:RedTry)
    next
      fix a assume e1_Throw: "e1 = Throw a"
      with wt1 obtain D fs where ha: "h a = Some(D,fs)" by fastforce
      show ?thesis
      proof cases
        assume "P  D * C"
        with e1_Throw ha show ?thesis by(fastforce intro!:RedTryCatch)
      next
        assume "¬ P  D * C"
        with e1_Throw ha show ?thesis by(force intro!:RedTryFail)
      qed
    qed
  next
    assume "¬ final e1"
    with WTrtTry show ?thesis by simp (fast intro:TryRed)
  qed
qed
(*>*)


end

Theory JWellForm

(*  Title:      Jinja/J/JWellForm.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Well-formedness Constraints›

theory JWellForm
imports "../Common/WellForm" WWellForm WellType DefAss
begin

definition wf_J_mdecl :: "J_prog  cname  J_mb mdecl  bool"
where
  "wf_J_mdecl P C    λ(M,Ts,T,(pns,body)).
  length Ts = length pns 
  distinct pns 
  this  set pns 
  (T'. P,[thisClass C,pns[↦]Ts]  body :: T'  P  T'  T) 
  𝒟 body {this}  set pns"

lemma wf_J_mdecl[simp]:
  "wf_J_mdecl P C (M,Ts,T,pns,body) 
  (length Ts = length pns 
  distinct pns 
  this  set pns 
  (T'. P,[thisClass C,pns[↦]Ts]  body :: T'  P  T'  T) 
  𝒟 body {this}  set pns)"
(*<*)by(simp add:wf_J_mdecl_def)(*>*)


abbreviation
  wf_J_prog :: "J_prog  bool" where
  "wf_J_prog == wf_prog wf_J_mdecl"

lemma wf_J_prog_wf_J_mdecl:
  " wf_J_prog P; (C, D, fds, mths)  set P; jmdcl  set mths 
   wf_J_mdecl P C jmdcl"
(*<*)
apply (simp add: wf_prog_def)
apply (simp add: wf_cdecl_def)
apply (erule conjE)+
apply (drule bspec, assumption)
apply simp
apply (erule conjE)+
apply (drule bspec, assumption)
apply (simp add: wf_mdecl_def split_beta)
done
(*>*)


lemma wf_mdecl_wwf_mdecl: "wf_J_mdecl P C Md  wwf_J_mdecl P C Md"
(*<*)by(fastforce simp:wwf_J_mdecl_def dest!:WT_fv)(*>*)


lemma wf_prog_wwf_prog: "wf_J_prog P  wwf_J_prog P"
(*<*)
apply(simp add:wf_prog_def wf_cdecl_def wf_mdecl_def)
apply(fast intro:wf_mdecl_wwf_mdecl)
done
(*>*)


end

Theory TypeSafe

(*  Title:      Jinja/J/SmallTypeSafe.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Type Safety Proof›

theory TypeSafe
imports Progress JWellForm
begin

subsection‹Basic preservation lemmas›

text‹First two easy preservation lemmas.›

theorem red_preserves_hconf:
  "P  e,(h,l)  e',(h',l')  (T E.  P,E,h  e : T; P  h    P  h' )"
and reds_preserves_hconf:
  "P  es,(h,l) [→] es',(h',l')  (Ts E.  P,E,h  es [:] Ts; P  h    P  h' )"
(*<*)
proof (induct rule:red_reds_inducts)
  case (RedNew h a C FDTs h' l)
  have new: "new_Addr h = Some a" and fields: "P  C has_fields FDTs"
   and h': "h' = h(a(C, init_fields FDTs))"
   and hconf: "P  h " by fact+
  from new have None: "h a = None" by(rule new_Addr_SomeD)
  moreover have "P,h  (C,init_fields FDTs) "
    using fields by(rule oconf_init_fields)
  ultimately show "P  h' " using h' by(fast intro: hconf_new[OF hconf])
next
  case (RedFAss h a C fs F D v l)
  let ?fs' = "fs((F,D)v)"
  have hconf: "P  h " and ha: "h a = Some(C,fs)"
   and wt: "P,E,h  addr aF{D}:=Val v : T" by fact+
  from wt ha obtain TF Tv where typeofv: "typeofh v = Some Tv"
    and has: "P  C has F:TF in D"
    and sub: "P  Tv  TF" by auto
  have "P,h  (C, ?fs') "
  proof (rule oconf_fupd[OF has])
    show "P,h  (C, fs) " using hconf ha by(simp add:hconf_def)
    show "P,h  v :≤ TF" using sub typeofv by(simp add:conf_def)
  qed
  with hconf ha show "P  h(a(C, ?fs')) "  by (rule hconf_upd_obj)
qed auto
(*>*)


theorem red_preserves_lconf:
  "P  e,(h,l)  e',(h',l') 
  (T E.  P,E,h  e:T; P,h  l (:≤) E   P,h'  l' (:≤) E)"
and reds_preserves_lconf:
  "P  es,(h,l) [→] es',(h',l') 
  (Ts E.  P,E,h  es[:]Ts; P,h  l (:≤) E   P,h'  l' (:≤) E)"
(*<*)
proof(induct rule:red_reds_inducts)
  case RedNew thus ?case
    by(fast intro:lconf_hext red_hext_incr[OF red_reds.RedNew])
next
  case RedLAss thus ?case by(fastforce elim: lconf_upd simp:conf_def)
next
  case RedFAss thus ?case
    by(fast intro:lconf_hext red_hext_incr[OF red_reds.RedFAss])
next
  case (InitBlockRed e h l V v e' h' l' v' T T')
  have red: "P  e, (h, l(Vv))  e',(h', l')"
   and IH: "T E .  P,E,h  e:T; P,h  l(Vv) (:≤) E 
                      P,h'  l' (:≤) E"
   and l'V: "l' V = Some v'" and lconf: "P,h  l (:≤) E"
   and wt: "P,E,h  {V:T := Val v; e} : T'" by fact+
  from lconf_hext[OF lconf red_hext_incr[OF red]]
  have "P,h'  l (:≤) E" .
  moreover from IH lconf wt have "P,h'  l' (:≤) E(VT)"
    by(auto simp del: fun_upd_apply simp: fun_upd_same lconf_upd2 conf_def)
  ultimately show "P,h'  l'(V := l V) (:≤) E"
    by (fastforce simp:lconf_def split:if_split_asm)
next
  case (BlockRedNone e h l V e' h' l' T T')
  have red: "P  e,(h, l(V := None))  e',(h', l')"
   and IH: "E T.  P,E,h  e : T; P,h  l(V:=None) (:≤) E 
                    P,h'  l' (:≤) E"
   and lconf: "P,h  l (:≤) E" and wt: "P,E,h  {V:T; e} : T'" by fact+
  from lconf_hext[OF lconf red_hext_incr[OF red]]
  have "P,h'  l (:≤) E" .
  moreover have "P,h'  l' (:≤) E(VT)"
    by(rule IH, insert lconf wt, auto simp:lconf_def)
  ultimately show "P,h'  l'(V := l V) (:≤) E"
    by (fastforce simp:lconf_def split:if_split_asm)
next
  case (BlockRedSome e h l V e' h' l' v T T')
  have red: "P  e,(h, l(V := None))  e',(h', l')"
   and IH: "E T. P,E,h  e : T; P,h  l(V:=None) (:≤) E
                    P,h'  l' (:≤) E"
   and lconf: "P,h  l (:≤) E" and wt: "P,E,h  {V:T; e} : T'" by fact+
  from lconf_hext[OF lconf red_hext_incr[OF red]]
  have "P,h'  l (:≤) E" .
  moreover have "P,h'  l' (:≤) E(VT)"
    by(rule IH, insert lconf wt, auto simp:lconf_def)
  ultimately show "P,h'  l'(V := l V) (:≤) E"
    by (fastforce simp:lconf_def split:if_split_asm)
qed auto
(*>*)


text‹Preservation of definite assignment more complex and requires a
few lemmas first.›

lemma [iff]: "A.  length Vs = length Ts; length vs = length Ts 
 𝒟 (blocks (Vs,Ts,vs,e)) A = 𝒟 e (A  set Vs)"
(*<*)
apply(induct Vs Ts vs e rule:blocks_induct)
apply(simp_all add:hyperset_defs)
done
(*>*)


lemma red_lA_incr: "P  e,(h,l)  e',(h',l')  dom l  𝒜 e   dom l'  𝒜 e'"
and reds_lA_incr: "P  es,(h,l) [→] es',(h',l')  dom l  𝒜s es   dom l'  𝒜s es'"
(*<*)
apply(induct rule:red_reds_inducts)
apply(simp_all del:fun_upd_apply add:hyperset_defs)
apply auto
apply(blast dest:red_lcl_incr)+
done
(*>*)


text‹Now preservation of definite assignment.›

lemma assumes wf: "wf_J_prog P"
shows red_preserves_defass:
  "P  e,(h,l)  e',(h',l')  𝒟 e dom l  𝒟 e' dom l'"
and "P  es,(h,l) [→] es',(h',l')  𝒟s es dom l  𝒟s es' dom l'"
(*<*)
proof (induct rule:red_reds_inducts)
  case BinOpRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case FAssRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CallObj thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
  case RedCall thus ?case
    apply (auto dest!:sees_wf_mdecl[OF wf] simp:wf_mdecl_def elim!:D_mono')
    by(auto simp:hyperset_defs)
next
  case InitBlockRed thus ?case
    by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply)
next
  case BlockRedNone thus ?case
    by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply)
next
  case BlockRedSome thus ?case
    by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply)
next
  case SeqRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CondRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case TryRed thus ?case
    by (fastforce dest:red_lcl_incr intro:D_mono' simp:hyperset_defs)
next
  case ListRed1 thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
  case RedWhile thus ?case by(auto simp:hyperset_defs elim!:D_mono')
qed (auto simp:hyperset_defs)
(*>*)


text‹Combining conformance of heap and local variables:›

definition sconf :: "J_prog  env  state  bool"   ("_,_  _ "   [51,51,51]50)
where
  "P,E  s     let (h,l) = s in P  h   P,h  l (:≤) E"

lemma red_preserves_sconf:
  " P  e,s  e',s'; P,E,hp s  e : T; P,E  s    P,E  s' "
(*<*)
by(fastforce intro:red_preserves_hconf red_preserves_lconf
            simp add:sconf_def)
(*>*)

lemma reds_preserves_sconf:
  " P  es,s [→] es',s'; P,E,hp s  es [:] Ts; P,E  s    P,E  s' "
(*<*)
by(fastforce intro:reds_preserves_hconf reds_preserves_lconf
            simp add:sconf_def)
(*>*)


subsection "Subject reduction"

lemma wt_blocks:
 "E.  length Vs = length Ts; length vs = length Ts  
       (P,E,h  blocks(Vs,Ts,vs,e) : T) =
       (P,E(Vs[↦]Ts),h  e:T  (Ts'. map (typeofh) vs = map Some Ts'  P  Ts' [≤] Ts))"
(*<*)
apply(induct Vs Ts vs e rule:blocks_induct)
apply (force simp add:rel_list_all2_Cons2)
apply simp_all
done
(*>*)


theorem assumes wf: "wf_J_prog P"
shows subject_reduction2: "P  e,(h,l)  e',(h',l') 
  (E T.  P,E  (h,l) ; P,E,h  e:T 
            T'. P,E,h'  e':T'  P  T'  T)"
and subjects_reduction2: "P  es,(h,l) [→] es',(h',l') 
  (E Ts.  P,E  (h,l) ; P,E,h  es [:] Ts 
             Ts'. P,E,h'  es' [:] Ts'  P  Ts' [≤] Ts)"
(*<*)
proof (induct rule:red_reds_inducts)
  case (RedCall h l a C fs M Ts T pns body D vs E T')
  have hp: "hp(h,l) a = Some(C,fs)"
   and "method": "P  C sees M: TsT = (pns,body) in D"
   and wt: "P,E,h  addr aM(map Val vs) : T'" by fact+
  obtain Ts' where wtes: "P,E,h  map Val vs [:] Ts'"
    and subs: "P  Ts' [≤] Ts" and T'isT: "T' = T"
    using wt "method" hp by (auto dest:sees_method_fun)
  from wtes subs have length_vs: "length vs = length Ts"
    by(fastforce simp:list_all2_iff dest!:WTrts_same_length)
  from sees_wf_mdecl[OF wf "method"] obtain T''
    where wtabody: "P,[this#pns [↦] Class D#Ts]  body :: T''"
    and T''subT: "P  T''  T" and length_pns: "length pns = length Ts"
    by(fastforce simp:wf_mdecl_def simp del:map_upds_twist)
  from wtabody have "P,Map.empty(this#pns [↦] Class D#Ts),h  body : T''"
    by(rule WT_implies_WTrt)
  hence "P,E(this#pns [↦] Class D#Ts),h  body : T''"
    by(rule WTrt_env_mono) simp
  hence "P,E,h  blocks(this#pns, Class D#Ts, Addr a#vs, body) : T''"
  using wtes subs hp sees_method_decl_above[OF "method"] length_vs length_pns
    by(fastforce simp add:wt_blocks rel_list_all2_Cons2)
  with T''subT T'isT show ?case by blast
next
  case RedNewFail thus ?case
    by (unfold sconf_def hconf_def) (fastforce elim!:typeof_OutOfMemory)
next
  case CastRed thus ?case
    by(clarsimp simp:is_refT_def)
      (blast intro: widens_trans dest!:widen_Class[THEN iffD1])
next
  case RedCastFail thus ?case
    by (unfold sconf_def hconf_def)  (fastforce elim!:typeof_ClassCast)
next
  case (BinOpRed1 e1 h l e1' h' l' bop e2)
  have red: "P  e1,(h,l)  e1',(h',l')"
   and IH: "E T. P,E  (h,l) ; P,E,h  e1:T
                  U. P,E,h'  e1' : U  P  U  T"
   and conf: "P,E  (h,l) " and wt: "P,E,h  e1 «bop» e2 : T" by fact+
  have "P,E,h'  e1' «bop» e2 : T"
  proof (cases bop)
    assume [simp]: "bop = Eq"
    from wt obtain T1 T2 where [simp]: "T = Boolean"
      and wt1: "P,E,h  e1 : T1" and wt2: "P,E,h  e2 : T2" by auto
    show ?thesis
      using WTrt_hext_mono[OF wt2 red_hext_incr[OF red]] IH[OF conf wt1]
      by auto
  next
    assume  [simp]: "bop = Add"
    from wt have [simp]: "T = Integer"
      and wt1: "P,E,h  e1 : Integer" and wt2: "P,E,h  e2 : Integer"
      by auto
    show ?thesis
      using IH[OF conf wt1] WTrt_hext_mono[OF wt2 red_hext_incr[OF red]]
      by auto
  qed
  thus ?case by auto
next
  case (BinOpRed2 e2 h l e2' h' l' v1 bop)
  have red: "P  e2,(h,l)  e2',(h',l')"
   and IH: "E T. P,E  (h,l) ; P,E,h  e2:T
                  U. P,E,h'  e2' : U  P  U  T"
   and conf: "P,E  (h,l) " and wt: "P,E,h  (Val v1) «bop» e2 : T" by fact+
  have "P,E,h'  (Val v1) «bop» e2' : T"
  proof (cases bop)
    assume [simp]: "bop = Eq"
    from wt obtain T1 T2 where [simp]: "T = Boolean"
      and wt1: "P,E,h  Val v1 : T1" and wt2: "P,E,h  e2:T2" by auto
    show ?thesis
      using IH[OF conf wt2] WTrt_hext_mono[OF wt1 red_hext_incr[OF red]]
      by auto
  next
    assume  [simp]: "bop = Add"
    from wt have [simp]: "T = Integer"
      and wt1: "P,E,h  Val v1 : Integer" and wt2: "P,E,h  e2 : Integer"
      by auto
    show ?thesis
      using IH[OF conf wt2] WTrt_hext_mono[OF wt1 red_hext_incr[OF red]]
      by auto
  qed
  thus ?case by auto
next
  case (RedBinOp bop) thus ?case
  proof (cases bop)
    case Eq thus ?thesis using RedBinOp by auto
  next
    case Add thus ?thesis using RedBinOp by auto
  qed
next
  case RedVar thus ?case by (fastforce simp:sconf_def lconf_def conf_def)
next
  case LAssRed thus ?case by(blast intro:widen_trans)
next
  case (FAccRed e h l e' h' l' F D)
  have IH: "E T. P,E  (h,l) ; P,E,h  e : T
                  U. P,E,h'  e' : U  P  U  T"
   and conf: "P,E  (h,l) " and wt: "P,E,h  eF{D} : T" by fact+
  ― ‹The goal: ?case = @{prop ?case}›
  ― ‹Now distinguish the two cases how wt can have arisen.›
  { fix C assume wte: "P,E,h  e : Class C"
             and has: "P  C has F:T in D"
    from IH[OF conf wte]
    obtain U where wte': "P,E,h'  e' : U" and UsubC: "P  U  Class C"
      by auto
    ― ‹Now distinguish what @{term U} can be.›
    { assume "U = NT" hence ?case using wte'
        by(blast intro:WTrtFAccNT widen_refl) }
    moreover
    { fix C' assume U: "U = Class C'" and C'subC: "P  C' * C"
      from has_field_mono[OF has C'subC] wte' U
      have ?case by(blast intro:WTrtFAcc) }
    ultimately have ?case using UsubC by(simp add: widen_Class) blast }
  moreover
  { assume "P,E,h  e : NT"
    hence "P,E,h'  e' : NT" using IH[OF conf] by fastforce
    hence ?case  by(fastforce intro:WTrtFAccNT widen_refl) }
  ultimately show ?case using wt by blast
next
  case RedFAcc thus ?case
    by(fastforce simp:sconf_def hconf_def oconf_def conf_def has_field_def
                dest:has_fields_fun)
next
  case RedFAccNull thus ?case
    by(fastforce intro: widen_refl WTThrow[OF WTVal] elim!: typeof_NullPointer
                simp: sconf_def hconf_def)
next
  case (FAssRed1 e h l e' h' l' F D e2)
  have red: "P  e,(h,l)  e',(h',l')"
   and IH: "E T. P,E  (h,l) ; P,E,h  e : T
                  U. P,E,h'  e' : U  P  U  T"
   and conf: "P,E  (h,l) " and wt: "P,E,h  eF{D}:=e2 : T" by fact+
  from wt have void: "T = Void" by blast
  ― ‹We distinguish if @{term e} has type @{term NT} or a Class type›
  ― ‹Remember ?case = @{term ?case}›
  { assume "P,E,h  e : NT"
    hence "P,E,h'  e' : NT" using IH[OF conf] by fastforce
    moreover obtain T2 where "P,E,h  e2 : T2" using wt by auto
    from this red_hext_incr[OF red] have  "P,E,h'  e2 : T2"
      by(rule WTrt_hext_mono)
    ultimately have ?case using void by(blast intro!:WTrtFAssNT)
  }
  moreover
  { fix C TF T2 assume wt1: "P,E,h  e : Class C" and wt2: "P,E,h  e2 : T2"
    and has: "P  C has F:TF in D" and sub: "P  T2  TF"
    obtain U where wt1': "P,E,h'  e' : U" and UsubC: "P  U  Class C"
      using IH[OF conf wt1] by blast
    have wt2': "P,E,h'  e2 : T2"
      by(rule WTrt_hext_mono[OF wt2 red_hext_incr[OF red]])
    ― ‹Is @{term U} the null type or a class type?›
    { assume "U = NT" with wt1' wt2' void have ?case
        by(blast intro!:WTrtFAssNT) }
    moreover
    { fix C' assume UClass: "U = Class C'" and "subclass": "P  C' * C"
      have "P,E,h'  e' : Class C'" using wt1' UClass by auto
      moreover have "P  C' has F:TF in D"
        by(rule has_field_mono[OF has "subclass"])
      ultimately have ?case using wt2' sub void by(blast intro:WTrtFAss) }
    ultimately have ?case using UsubC by(auto simp add:widen_Class) }
  ultimately show ?case using wt by blast
next
  case (FAssRed2 e2 h l e2' h' l' v F D)
  have red: "P  e2,(h,l)  e2',(h',l')"
   and IH: "E T. P,E  (h,l) ; P,E,h  e2 : T
                  U. P,E,h'  e2' : U  P  U  T"
   and conf: "P,E  (h,l) " and wt: "P,E,h  Val vF{D}:=e2 : T" by fact+
  from wt have [simp]: "T = Void" by auto
  from wt show ?case
  proof (rule WTrt_elim_cases)
    fix C TF T2
    assume wt1: "P,E,h  Val v : Class C"
      and has: "P  C has F:TF in D"
      and wt2: "P,E,h  e2 : T2" and TsubTF: "P  T2  TF"
    have wt1': "P,E,h'  Val v : Class C"
      by(rule WTrt_hext_mono[OF wt1 red_hext_incr[OF red]])
    obtain T2' where wt2': "P,E,h'  e2' : T2'" and T'subT: "P  T2'  T2"
      using IH[OF conf wt2] by blast
    have "P,E,h'  Val vF{D}:=e2' : Void"
      by(rule WTrtFAss[OF wt1' has wt2' widen_trans[OF T'subT TsubTF]])
    thus ?case by auto
  next
    fix T2 assume null: "P,E,h  Val v : NT" and wt2: "P,E,h  e2 : T2"
    from null have "v = Null" by simp
    moreover
    obtain T2' where "P,E,h'  e2' : T2'  P  T2'  T2"
      using IH[OF conf wt2] by blast
    ultimately show ?thesis by(fastforce intro:WTrtFAssNT)
  qed
next
  case RedFAss thus ?case by(auto simp del:fun_upd_apply)
next
  case RedFAssNull thus ?case
    by(fastforce intro: WTThrow[OF WTVal] elim!:typeof_NullPointer simp:sconf_def hconf_def)
next
  case (CallObj e h l e' h' l' M es)
  have red: "P  e,(h,l)  e',(h',l')"
   and IH: "E T. P,E  (h,l) ; P,E,h  e : T
                  U. P,E,h'  e' : U  P  U  T"
   and conf: "P,E  (h,l) " and wt: "P,E,h  eM(es) : T" by fact+
  ― ‹We distinguish if @{term e} has type @{term NT} or a Class type›
  ― ‹Remember ?case = @{term ?case}›
  { assume "P,E,h  e:NT"
    hence "P,E,h'  e' : NT" using IH[OF conf] by fastforce
    moreover
    fix Ts assume wtes: "P,E,h  es [:] Ts"
    have "P,E,h'  es [:] Ts"
      by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
    ultimately have ?case by(blast intro!:WTrtCallNT) }
  moreover
  { fix C D Ts Us pns body
    assume wte: "P,E,h  e : Class C"
      and "method": "P  C sees M:TsT = (pns,body) in D"
      and wtes: "P,E,h  es [:] Us" and subs: "P  Us [≤] Ts"
    obtain U where wte': "P,E,h'  e' : U" and UsubC: "P  U  Class C"
      using IH[OF conf wte] by blast
    ― ‹Is @{term U} the null type or a class type?›
    { assume "U = NT"
      moreover have "P,E,h'  es [:] Us"
        by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
      ultimately have ?case using wte' by(blast intro!:WTrtCallNT) }
    moreover
    { fix C' assume UClass: "U = Class C'" and "subclass": "P  C' * C"
      have "P,E,h'  e' : Class C'" using wte' UClass by auto
      moreover obtain Ts' T' pns' body' D'
        where method': "P  C' sees M:Ts'T' = (pns',body') in D'"
        and subs': "P  Ts [≤] Ts'" and sub': "P  T'  T"
        using Call_lemma[OF "method" "subclass" wf] by fast
      moreover have "P,E,h'  es [:] Us"
        by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
      ultimately have ?case
        using subs by(blast intro:WTrtCall rtrancl_trans widens_trans) }
    ultimately have ?case using UsubC by(auto simp add:widen_Class) }
  ultimately show ?case using wt by auto
next
  case (CallParams es h l es' h' l' v M)
  have reds: "P  es,(h,l) [→] es',(h',l')"
   and IH: "E Ts. P,E  (h,l) ; P,E,h  es [:] Ts
                  Us. P,E,h'  es' [:] Us  P  Us [≤] Ts"
   and conf: "P,E  (h,l) " and wt: "P,E,h  Val vM(es) : T" by fact+
  from wt show ?case
  proof (rule WTrt_elim_cases)
    fix C D Ts Us pns body
    assume wte: "P,E,h  Val v : Class C"
      and "P  C sees M:TsT = (pns,body) in D"
      and wtes: "P,E,h  es [:] Us" and "P  Us [≤] Ts"
    moreover have "P,E,h'  Val v : Class C"
      by(rule WTrt_hext_mono[OF wte reds_hext_incr[OF reds]])
    moreover
    obtain Us' where "P,E,h'  es' [:] Us'  P  Us' [≤] Us"
      using IH[OF conf wtes] by blast
    ultimately show ?thesis by(blast intro:WTrtCall widens_trans)
  next
    fix Us
    assume null: "P,E,h  Val v : NT" and wtes: "P,E,h  es [:] Us"
    from null have "v = Null" by simp
    moreover
    obtain Us' where "P,E,h'  es' [:] Us'  P  Us' [≤] Us"
      using IH[OF conf wtes] by blast
    ultimately show ?thesis by(fastforce intro:WTrtCallNT)
  qed
next
  case RedCallNull thus ?case
    by(fastforce intro: WTThrow[OF WTVal] elim!:typeof_NullPointer simp: sconf_def hconf_def)
next
  case (InitBlockRed e h l V v e' h' l' v' T E T')
  have red: "P  e, (h,l(Vv))  e',(h',l')"
   and IH: "E T. P,E  (h,l(Vv)) ; P,E,h  e : T
                     U. P,E,h'  e' : U  P  U  T"
   and v': "l' V = Some v'" and conf: "P,E  (h,l) "
   and wt: "P,E,h  {V:T := Val v; e} : T'" by fact+
  from wt obtain T1 where wt1: "typeofh v = Some T1"
    and T1subT: "P  T1  T" and wt2: "P,E(VT),h  e : T'" by auto
  have lconf2: "P,h  l(Vv) (:≤) E(VT)" using conf wt1 T1subT
    by(simp add:sconf_def lconf_upd2 conf_def)
  have "T1'. typeofh' v' = Some T1'  P  T1'  T"
    using v' red_preserves_lconf[OF red wt2 lconf2]
    by(fastforce simp:lconf_def conf_def)
  with IH conf lconf2 wt2 show ?case by (fastforce simp add:sconf_def)
next
  case BlockRedNone thus ?case
    by(auto simp del:fun_upd_apply)(fastforce simp:sconf_def lconf_def)
next
  case (BlockRedSome e h l V e' h' l' v T E Te)
  have red: "P  e,(h,l(V:=None))  e',(h',l')"
   and IH: "E T. P,E  (h,l(V:=None)) ; P,E,h  e : T
                    T'. P,E,h'  e' : T'  P  T'  T"
   and Some: "l' V = Some v" and conf: "P,E  (h,l) "
   and wt: "P,E,h  {V:T; e} : Te" by fact+
  obtain Te' where IH': "P,E(VT),h'  e' : Te'  P  Te'  Te"
    using IH conf wt by(fastforce simp:sconf_def lconf_def)
  have "P,h'  l' (:≤) E(VT)" using conf wt
    by(fastforce intro:red_preserves_lconf[OF red] simp:sconf_def lconf_def)
  hence "P,h'  v :≤ T" using Some by(fastforce simp:lconf_def)
  with IH' show ?case
    by(fastforce simp:sconf_def conf_def fun_upd_same simp del:fun_upd_apply)
next
  case SeqRed thus ?case
    by auto (blast dest:WTrt_hext_mono[OF _ red_hext_incr])
next
  case CondRed thus ?case
    by auto (blast intro:WTrt_hext_mono[OF _ red_hext_incr])+
next
  case ThrowRed thus ?case
    by(auto simp:is_refT_def)(blast dest:widen_Class[THEN iffD1])+
next
  case RedThrowNull thus ?case
    by(fastforce intro: WTThrow[OF WTVal] elim!:typeof_NullPointer simp:sconf_def hconf_def)
next
  case TryRed thus ?case
    by auto (blast intro:widen_trans WTrt_hext_mono[OF _ red_hext_incr])
next
  case RedTryFail thus ?case
    by(fastforce intro: WTrtThrow[OF WTrtVal] simp:sconf_def hconf_def)
next
  case ListRed1 thus ?case
    by(fastforce dest: WTrts_hext_mono[OF _ red_hext_incr])
next
  case ListRed2 thus ?case
    by(fastforce dest: hext_typeof_mono[OF reds_hext_incr])
qed fastforce+ (* esp all Throw propagation rules are dealt with here *)
(*>*)


corollary subject_reduction:
  " wf_J_prog P; P  e,s  e',s'; P,E  s ; P,E,hp s  e:T 
   T'. P,E,hp s'  e':T'  P  T'  T"
(*<*)by(cases s, cases s', fastforce dest:subject_reduction2)(*>*)

corollary subjects_reduction:
  " wf_J_prog P; P  es,s [→] es',s'; P,E  s ; P,E,hp s  es[:]Ts 
   Ts'. P,E,hp s'  es'[:]Ts'  P  Ts' [≤] Ts"
(*<*)by(cases s, cases s', fastforce dest:subjects_reduction2)(*>*)


subsection ‹Lifting to →*›

text‹Now all these preservation lemmas are first lifted to the transitive
closure \dots›

lemma Red_preserves_sconf:
assumes wf: "wf_J_prog P" and Red: "P  e,s →* e',s'"
shows "T.  P,E,hp s  e : T; P,E  s    P,E  s' "
(*<*)
using Red
proof (induct rule:converse_rtrancl_induct2)
  case refl show ?case by fact
next
  case step thus ?case
    by(blast intro:red_preserves_sconf dest: subject_reduction[OF wf])
qed
(*>*)


lemma Red_preserves_defass:
assumes wf: "wf_J_prog P" and reds: "P  e,s →* e',s'"
shows "𝒟 e dom(lcl s)  𝒟 e' dom(lcl s')"
using reds
proof (induct rule:converse_rtrancl_induct2)
  case refl thus ?case .
next
  case (step e s e' s') thus ?case
    by(cases s,cases s')(auto dest:red_preserves_defass[OF wf])
qed


lemma Red_preserves_type:
assumes wf: "wf_J_prog P" and Red: "P  e,s →* e',s'"
shows "!!T.  P,E  s; P,E,hp s  e:T 
     T'. P  T'  T  P,E,hp s'  e':T'"
(*<*)
using Red
proof (induct rule:converse_rtrancl_induct2)
  case refl thus ?case by blast
next
  case step thus ?case
    by(blast intro:widen_trans red_preserves_sconf
             dest:subject_reduction[OF wf])
qed
(*>*)


subsection ‹Lifting to ⇒›

text‹\dots and now to the big step semantics, just for fun.›

lemma eval_preserves_sconf:
  " wf_J_prog P; P  e,s  e',s'; P,E  e::T; P,E  s   P,E  s'"
(*<*)
by(blast intro:Red_preserves_sconf big_by_small WT_implies_WTrt wf_prog_wwf_prog)
(*>*)


lemma eval_preserves_type: assumes wf: "wf_J_prog P"
shows " P  e,s  e',s'; P,E  s; P,E  e::T 
    T'. P  T'  T  P,E,hp s'  e':T'"
(*<*)
by(blast dest:big_by_small[OF wf_prog_wwf_prog[OF wf]]
              WT_implies_WTrt Red_preserves_type[OF wf])
(*>*)


subsection "The final polish"

text‹The above preservation lemmas are now combined and packed nicely.›

definition wf_config :: "J_prog  env  state  expr  ty  bool"   ("_,_,_  _ : _ "   [51,0,0,0,0]50)
where
  "P,E,s  e:T     P,E  s   P,E,hp s  e:T"

theorem Subject_reduction: assumes wf: "wf_J_prog P"
shows "P  e,s  e',s'  P,E,s  e : T 
        T'. P,E,s'  e' : T'   P  T'  T"
(*<*)
by(force simp add: wf_config_def
   elim:red_preserves_sconf dest:subject_reduction[OF wf])
(*>*)


theorem Subject_reductions:
assumes wf: "wf_J_prog P" and reds: "P  e,s →* e',s'"
shows "T. P,E,s  e:T   T'. P,E,s'  e':T'   P  T'  T"
(*<*)
using reds
proof (induct rule:converse_rtrancl_induct2)
  case refl thus ?case by blast
next
  case step thus ?case
    by(blast dest:Subject_reduction[OF wf] intro:widen_trans)
qed
(*>*)


corollary Progress: assumes wf: "wf_J_prog P"
shows " P,E,s   e : T ; 𝒟 e dom(lcl s); ¬ final e   e' s'. P  e,s  e',s'"
(*<*)
using progress[OF wf_prog_wwf_prog[OF wf]]
by(auto simp:wf_config_def sconf_def)
(*>*)


corollary TypeSafety:
  " wf_J_prog P; P,E  s ; P,E  e::T; 𝒟 e dom(lcl s);
     P  e,s →* e',s'; ¬(e'' s''. P  e',s'  e'',s'') 
  (v. e' = Val v  P,hp s'  v :≤ T) 
      (a. e' = Throw a  a  dom(hp s'))"
(*<*)
apply(subgoal_tac " P,E,s  e:T ")
 prefer 2
 apply(fastforce simp:wf_config_def dest:WT_implies_WTrt)
apply(frule (2) Subject_reductions)
apply(erule exE conjE)+
apply(frule (2) Red_preserves_defass)
apply(subgoal_tac "final e'")
 prefer 2
 apply(blast dest: Progress)
apply (fastforce simp:wf_config_def final_def conf_def dest: Progress)
done
(*>*)


end

Theory Annotate

(*  Title:      Jinja/J/Annotate.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Program annotation›

theory Annotate imports WellType begin

(*<*)
abbreviation (output)
  unanFAcc :: "expr  vname  expr" ("(__)" [10,10] 90) where
  "unanFAcc e F == FAcc e F []"

abbreviation (output)
  unanFAss :: "expr  vname  expr  expr" ("(__ := _)" [10,0,90] 90) where
  "unanFAss e F e' == FAss e F [] e'"
(*>*)

inductive
  Anno :: "[J_prog,env, expr     , expr]  bool"
         ("_,_  _  _"   [51,0,0,51]50)
  and Annos :: "[J_prog,env, expr list, expr list]  bool"
         ("_,_  _ [↝] _" [51,0,0,51]50)
  for P :: J_prog
where
  
  AnnoNew: "P,E  new C  new C"
| AnnoCast: "P,E  e  e'  P,E  Cast C e  Cast C e'"
| AnnoVal: "P,E  Val v  Val v"
| AnnoVarVar: "E V = T  P,E  Var V  Var V"
| AnnoVarField: " E V = None; E this = Class C; P  C sees V:T in D 
                P,E  Var V  Var thisV{D}"
| AnnoBinOp:
  " P,E  e1  e1';  P,E  e2  e2' 
    P,E  e1 «bop» e2  e1' «bop» e2'"
| AnnoLAssVar:
  " E V = T; P,E  e  e'   P,E  V:=e  V:=e'"
| AnnoLAssField:
  " E V = None; E this = Class C; P  C sees V:T in D; P,E  e  e' 
    P,E  V:=e  Var thisV{D} := e'"
| AnnoFAcc:
  " P,E  e  e';  P,E  e' :: Class C;  P  C sees F:T in D 
    P,E  eF{[]}  e'F{D}"
| AnnoFAss: " P,E  e1  e1';  P,E  e2  e2';
             P,E  e1' :: Class C; P  C sees F:T in D 
           P,E  e1F{[]} := e2  e1'F{D} := e2'"
| AnnoCall:
  " P,E  e  e';  P,E  es [↝] es' 
    P,E  Call e M es  Call e' M es'"
| AnnoBlock:
  "P,E(V  T)  e  e'    P,E  {V:T; e}  {V:T; e'}"
| AnnoComp: " P,E  e1  e1';  P,E  e2  e2' 
             P,E  e1;;e2  e1';;e2'"
| AnnoCond: " P,E  e  e'; P,E  e1  e1';  P,E  e2  e2' 
           P,E  if (e) e1 else e2  if (e') e1' else e2'"
| AnnoLoop: " P,E  e  e';  P,E  c  c' 
           P,E  while (e) c  while (e') c'"
| AnnoThrow: "P,E  e  e'    P,E  throw e  throw e'"
| AnnoTry: " P,E  e1  e1';  P,E(V  Class C)  e2  e2' 
          P,E  try e1 catch(C V) e2  try e1' catch(C V) e2'"

| AnnoNil: "P,E  [] [↝] []"
| AnnoCons: " P,E  e  e';  P,E  es [↝] es' 
             P,E  e#es [↝] e'#es'"

end

Theory Examples

(*  Title:      Jinja/J/Examples.thy

    Author:     Christoph Petzinger
    Copyright   2004 Technische Universitaet Muenchen
*)

section ‹Example Expressions›

theory Examples imports Expr begin

definition classObject::"J_mb cdecl"
where
  "classObject == (''Object'','''',[],[])"


definition classI :: "J_mb cdecl"
where
  "classI ==
  (''I'', Object,
  [],
  [(''mult'',[Integer,Integer],Integer,[''i'',''j''],
   if (Var ''i'' «Eq» Val(Intg 0)) (Val(Intg 0))
   else Var ''j'' «Add»
       Var this  ''mult''([Var ''i'' «Add» Val(Intg (- 1)),Var ''j'']))
  ])"


definition classL :: "J_mb cdecl"
where
  "classL ==
  (''L'', Object,
  [(''F'',Integer), (''N'',Class ''L'')],
  [(''app'',[Class ''L''],Void,[''l''],
   if (Var this  ''N''{''L''} «Eq» null)
      (Var this  ''N''{''L''} := Var ''l'')
   else (Var this  ''N''{''L''})  ''app''([Var ''l'']))
  ])"


definition testExpr_BuildList :: "expr"
where
  "testExpr_BuildList ==
  {''l1'':Class ''L'' := new ''L'';
   Var ''l1''''F''{''L''} := Val(Intg 1);;
  {''l2'':Class ''L'' := new ''L'';
   Var ''l2'' ''F''{''L''} := Val(Intg 2);;
  {''l3'':Class ''L'' := new ''L'';
   Var ''l3'' ''F''{''L''} := Val(Intg 3);;
  {''l4'':Class ''L'' := new ''L'';
   Var ''l4'' ''F''{''L''} := Val(Intg 4);;
   Var ''l1''''app''([Var ''l2'']);;
   Var ''l1''''app''([Var ''l3'']);;
   Var ''l1''''app''([Var ''l4''])}}}}"

definition testExpr1 ::"expr"
where
  "testExpr1 == Val(Intg 5)"
definition testExpr2 ::"expr"
where
  "testExpr2 == BinOp (Val(Intg 5)) Add (Val(Intg 6))"
definition testExpr3 ::"expr"
where
  "testExpr3 == BinOp (Var ''V'') Add (Val(Intg 6))"
definition testExpr4 ::"expr"
where
  "testExpr4 == ''V'' := Val(Intg 6)"
definition testExpr5 ::"expr"
where
  "testExpr5 == new ''Object'';; {''V'':(Class ''C'') := new ''C''; Var ''V''''F''{''C''} := Val(Intg 42)}"
definition testExpr6 ::"expr"
where
  "testExpr6 == {''V'':(Class ''I'') := new ''I''; Var ''V''''mult''([Val(Intg 40),Val(Intg 4)])}"

definition mb_isNull:: "expr"
where
  "mb_isNull == Var this  ''test''{''A''} «Eq» null "

definition mb_add:: "expr"
where
  "mb_add == (Var this  ''int''{''A''} :=( Var this  ''int''{''A''} «Add» Var ''i''));; (Var this  ''int''{''A''})"

definition mb_mult_cond:: "expr"  
where
  "mb_mult_cond == (Var ''j'' «Eq» Val (Intg 0)) «Eq» Val (Bool False)"

definition mb_mult_block:: "expr"
where
  "mb_mult_block == ''temp'':=(Var ''temp'' «Add» Var ''i'');;''j'':=(Var ''j'' «Add» Val (Intg (- 1)))"

definition mb_mult:: "expr"
where
  "mb_mult == {''temp'':Integer:=Val (Intg 0); While (mb_mult_cond) mb_mult_block;; ( Var this  ''int''{''A''} := Var ''temp'';; Var ''temp'' )}"

definition classA:: "J_mb cdecl"
where
  "classA ==
  (''A'', Object,
  [(''int'',Integer),
   (''test'',Class ''A'') ],
  [(''isNull'',[],Boolean,[], mb_isNull),
   (''add'',[Integer],Integer,[''i''], mb_add),
   (''mult'',[Integer,Integer],Integer,[''i'',''j''], mb_mult) ])"
  

definition testExpr_ClassA:: "expr"
where
  "testExpr_ClassA ==
  {''A1'':Class ''A'':= new ''A''; 
  {''A2'':Class ''A'':= new ''A''; 
  {''testint'':Integer:= Val (Intg 5);
   (Var ''A2'' ''int''{''A''} := (Var ''A1'' ''add''([Var ''testint''])));;
   (Var ''A2'' ''int''{''A''} := (Var ''A1'' ''add''([Var ''testint''])));;
   Var ''A2'' ''mult''([Var ''A2'' ''int''{''A''}, Var ''testint'']) }}}"

end

Theory execute_Bigstep

(*  Title:      Jinja/J/execute_Bigstep.thy
    Author:     Tobias Nipkow
    Copyright   2004 Technische Universitaet Muenchen
*)

section ‹Code Generation For BigStep›

theory execute_Bigstep
imports
  BigStep Examples
  "HOL-Library.Code_Target_Numeral"
begin

inductive map_val :: "expr list  val list  bool"
where
  Nil: "map_val [] []"
| Cons: "map_val xs ys  map_val (Val y # xs) (y # ys)"

inductive map_val2 :: "expr list  val list  expr list  bool"
where
  Nil: "map_val2 [] [] []"
| Cons: "map_val2 xs ys zs  map_val2 (Val y # xs) (y # ys) zs"
| Throw: "map_val2 (throw e # xs) [] (throw e # xs)"

theorem map_val_conv: "(xs = map Val ys) = map_val xs ys"
(*<*)
proof -
  have "ys. xs = map Val ys  map_val xs ys"
    apply (induct xs type:list)
    apply (case_tac ys)
    apply simp
    apply (rule map_val.Nil)
    apply simp
    apply (case_tac ys)
    apply simp
    apply simp
    apply (rule map_val.Cons)
    apply simp
    done
  moreover have "map_val xs ys  xs = map Val ys"
    by (erule map_val.induct) simp+
  ultimately show ?thesis ..
qed
(*>*)

theorem map_val2_conv:
 "(xs = map Val ys @ throw e # zs) = map_val2 xs ys (throw e # zs)"
(*<*)
proof -
  have "ys. xs = map Val ys @ throw e # zs  map_val2 xs ys (throw e # zs)"
    apply (induct xs type:list)
    apply (case_tac ys)
    apply simp
    apply simp
    apply simp
    apply (case_tac ys)
    apply simp
    apply (rule map_val2.Throw)
    apply simp
    apply (rule map_val2.Cons)
    apply simp
    done
  moreover have "map_val2 xs ys (throw e # zs)  xs = map Val ys @ throw e # zs"
    by (erule map_val2.induct) simp+
  ultimately show ?thesis ..
qed
(*>*)

lemma CallNull2:
  " P  e,s0  null,s1;  P  ps,s1 [⇒] evs,s2; map_val evs vs 
   P  eM(ps),s0  THROW NullPointer,s2"
apply(rule CallNull, assumption+)
apply(simp add: map_val_conv[symmetric])
done


lemma CallParamsThrow2:
  " P  e,s0  Val v,s1; P  es,s1 [⇒] evs,s2;
     map_val2 evs vs (throw ex # es'') 
    P  eM(es),s0  throw ex,s2"
apply(rule eval_evals.CallParamsThrow, assumption+)
apply(simp add: map_val2_conv[symmetric])
done

lemma Call2:
  " P  e,s0  addr a,s1;  P  ps,s1 [⇒] evs,(h2,l2);
     map_val evs vs;
     h2 a = Some(C,fs);  P  C sees M:TsT = (pns,body) in D;
     length vs = length pns;  l2' = [thisAddr a, pns[↦]vs];
     P  body,(h2,l2')  e',(h3,l3) 
   P  eM(ps),s0  e',(h3,l2)"
apply(rule Call, assumption+)
apply(simp add: map_val_conv[symmetric])
apply assumption+
done

code_pred 
  (modes: i ⇒ o ⇒ bool)
  map_val 
.

code_pred
  (modes: i ⇒ o ⇒ o ⇒ bool)
  map_val2
.

lemmas [code_pred_intro] =
 eval_evals.New eval_evals.NewFail
 eval_evals.Cast eval_evals.CastNull eval_evals.CastFail eval_evals.CastThrow
 eval_evals.Val eval_evals.Var
 eval_evals.BinOp eval_evals.BinOpThrow1 eval_evals.BinOpThrow2
 eval_evals.LAss eval_evals.LAssThrow
 eval_evals.FAcc eval_evals.FAccNull eval_evals.FAccThrow
 eval_evals.FAss eval_evals.FAssNull
 eval_evals.FAssThrow1 eval_evals.FAssThrow2
 eval_evals.CallObjThrow

declare CallNull2 [code_pred_intro CallNull2]
declare CallParamsThrow2 [code_pred_intro CallParamsThrow2]
declare Call2 [code_pred_intro Call2]

lemmas [code_pred_intro] =
 eval_evals.Block
 eval_evals.Seq eval_evals.SeqThrow
 eval_evals.CondT eval_evals.CondF eval_evals.CondThrow
 eval_evals.WhileF eval_evals.WhileT
 eval_evals.WhileCondThrow

declare eval_evals.WhileBodyThrow [code_pred_intro WhileBodyThrow2]

lemmas [code_pred_intro] =
 eval_evals.Throw eval_evals.ThrowNull
 eval_evals.ThrowThrow
 eval_evals.Try eval_evals.TryCatch eval_evals.TryThrow
 eval_evals.Nil eval_evals.Cons eval_evals.ConsThrow

code_pred
  (modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool as execute)
  eval
proof -
  case eval
  from eval.prems show thesis
  proof(cases (no_simp))
    case CallNull thus ?thesis
      by(rule eval.CallNull2[OF refl])(simp add: map_val_conv[symmetric])
  next
    case CallParamsThrow thus ?thesis
      by(rule eval.CallParamsThrow2[OF refl])(simp add: map_val2_conv[symmetric])
  next
    case Call thus ?thesis
      by -(rule eval.Call2[OF refl], simp_all add: map_val_conv[symmetric])
  next
    case WhileBodyThrow thus ?thesis by(rule eval.WhileBodyThrow2[OF refl])
  qed(assumption|erule (4) eval.that[OF refl]|erule (3) eval.that[OF refl])+
next
  case evals
  from evals.prems show thesis
    by(cases (no_simp))(assumption|erule (3) evals.that[OF refl])+
qed

notation execute ("_  ((1_,/_) / ⟨'_, '_⟩)" [51,0,0] 81)

definition "test1 = []  testExpr1,(Map.empty,Map.empty)  ⟨_,_⟩"
definition "test2 = []  testExpr2,(Map.empty,Map.empty)  ⟨_,_⟩"
definition "test3 = []  testExpr3,(Map.empty,Map.empty(''V''Intg 77))  ⟨_,_⟩"
definition "test4 = []  testExpr4,(Map.empty,Map.empty)  ⟨_,_⟩"
definition "test5 = [(''Object'',('''',[],[])),(''C'',(''Object'',[(''F'',Integer)],[]))]  testExpr5,(Map.empty,Map.empty)  ⟨_,_⟩"
definition "test6 = [(''Object'',('''',[],[])), classI]  testExpr6,(Map.empty,Map.empty)  ⟨_,_⟩"

definition "V = ''V''"
definition "C = ''C''"
definition "F = ''F''"

ML_val val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 5)), _), _) = Predicate.yield @{code test1};
  val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 11)), _), _) = Predicate.yield @{code test2};
  val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 83)), _), _) = Predicate.yield @{code test3};

  val SOME ((_, (_, l)), _) = Predicate.yield @{code test4};
  val SOME (@{code Intg} (@{code int_of_integer} 6)) = l @{code V};

  val SOME ((_, (h, _)), _) = Predicate.yield @{code test5};
  val SOME (c, fs) = h (@{code nat_of_integer} 1);
  val SOME (obj, _) = h (@{code nat_of_integer} 0);
  val SOME (@{code Intg} i) = fs (@{code F}, @{code C});
  @{assert} (c = @{code C} andalso obj = @{code Object} andalso i = @{code int_of_integer} 42);

  val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 160)), _), _) = Predicate.yield @{code test6};

definition "test7 = [classObject, classL]  testExpr_BuildList, (Map.empty,Map.empty)  ⟨_,_⟩"

definition "L = ''L''"
definition "N = ''N''"

ML_val val SOME ((_, (h, _)), _) = Predicate.yield @{code test7};
  val SOME (_, fs1) = h (@{code nat_of_integer} 0);
  val SOME (_, fs2) = h (@{code nat_of_integer} 1);
  val SOME (_, fs3) = h (@{code nat_of_integer} 2);
  val SOME (_, fs4) = h (@{code nat_of_integer} 3);

  val F = @{code "F"};
  val L = @{code "L"};
  val N = @{code "N"};

  @{assert} (fs1 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 1)) andalso
     fs1 (N, L) = SOME (@{code Addr} (@{code nat_of_integer} 1)) andalso
     fs2 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 2)) andalso
     fs2 (N, L) = SOME (@{code Addr} (@{code nat_of_integer} 2)) andalso
     fs3 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 3)) andalso
     fs3 (N, L) = SOME (@{code Addr} (@{code nat_of_integer} 3)) andalso
     fs4 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 4)) andalso
     fs4 (N, L) = SOME @{code Null});

definition "test8 = [classObject, classA]  testExpr_ClassA, (Map.empty,Map.empty)  ⟨_,_⟩"
definition "i = ''int''"
definition "t = ''test''"
definition "A = ''A''"

ML_val val SOME ((_, (h, l)), _) = Predicate.yield @{code test8};
  val SOME (_, fs1) = h (@{code nat_of_integer} 0);
  val SOME (_, fs2) = h (@{code nat_of_integer} 1);

  val i = @{code "i"};
  val t = @{code "t"};
  val A = @{code "A"};

  @{assert} (fs1 (i, A) = SOME (@{code Intg} (@{code int_of_integer} 10)) andalso 
     fs1 (t, A) = SOME @{code Null} andalso
     fs2 (i, A) = SOME (@{code Intg} (@{code int_of_integer} 50)) andalso 
     fs2 (t, A) = SOME @{code Null});

end

Theory execute_WellType

(*  Title:      Jinja/J/execute_WellType.thy
    Author:     Christoph Petzinger
    Copyright   2004 Technische Universitaet Muenchen
*)

section ‹Code Generation For WellType›

theory execute_WellType
imports
  WellType Examples
begin

(* Replace WT_WTs.WTCond with new intros WT_WTs.WTCond1 and WT_WTs.WTCond2 *)

lemma WTCond1:
  "P,E  e :: Boolean;  P,E  e1::T1;  P,E  e2::T2; P  T1  T2;
    P  T2  T1  T2 = T1   P,E  if (e) e1 else e2 :: T2"
by (fastforce)

lemma WTCond2:
  "P,E  e :: Boolean;  P,E  e1::T1;  P,E  e2::T2; P  T2  T1;
    P  T1  T2  T1 = T2   P,E  if (e) e1 else e2 :: T1"
by (fastforce)

lemmas [code_pred_intro] =
  WT_WTs.WTNew
  WT_WTs.WTCast
  WT_WTs.WTVal
  WT_WTs.WTVar
  WT_WTs.WTBinOpEq
  WT_WTs.WTBinOpAdd
  WT_WTs.WTLAss
  WT_WTs.WTFAcc
  WT_WTs.WTFAss
  WT_WTs.WTCall
  WT_WTs.WTBlock
  WT_WTs.WTSeq

declare
  WTCond1 [code_pred_intro WTCond1]
  WTCond2 [code_pred_intro WTCond2]

lemmas [code_pred_intro] =
  WT_WTs.WTWhile
  WT_WTs.WTThrow
  WT_WTs.WTTry
  WT_WTs.WTNil
  WT_WTs.WTCons

code_pred
  (modes: i ⇒ i ⇒ i ⇒ i ⇒ bool as type_check, i ⇒ i ⇒ i ⇒ o ⇒ bool as infer_type)
  WT
proof -
  case WT
  from WT.prems show thesis
  proof(cases (no_simp))
    case (WTCond E e e1 T1 e2 T2 T)
    from x  T1  T2  x  T2  T1 show thesis
    proof
      assume "x  T1  T2"
      with x  T1  T2  T = T2 have "T = T2" ..
      from xa = E xb = if (e) e1 else e2 xc = T x,E  e :: Boolean› 
        x,E  e1 :: T1 x,E  e2 :: T2 x  T1  T2 x  T2  T1  T = T1
      show ?thesis unfolding T = T2 by(rule WT.WTCond1[OF refl])
    next
      assume "x  T2  T1"
      with x  T2  T1  T = T1 have "T = T1" ..
      from xa = E xb = if (e) e1 else e2 xc = T x,E  e :: Boolean› 
        x,E  e1 :: T1 x,E  e2 :: T2 x  T2  T1 x  T1  T2  T = T2
      show ?thesis unfolding T = T1 by(rule WT.WTCond2[OF refl])
    qed
  qed(assumption|erule (2) WT.that[OF refl])+
next
  case WTs
  from WTs.prems show thesis
    by(cases (no_simp))(assumption|erule (2) WTs.that[OF refl])+
qed

notation infer_type ("_,_  _ :: '_" [51,51,51]100)

definition test1 where "test1 = [],Map.empty  testExpr1 :: _"
definition test2 where "test2 = [], Map.empty   testExpr2 :: _"
definition test3 where "test3 = [], Map.empty(''V''  Integer)   testExpr3 :: _"
definition test4 where "test4 = [], Map.empty(''V''  Integer)   testExpr4 :: _"
definition test5 where "test5 = [classObject, (''C'',(''Object'',[(''F'',Integer)],[]))], Map.empty   testExpr5 :: _"
definition test6 where "test6 = [classObject, classI], Map.empty   testExpr6 :: _"

ML_val val SOME(@{code Integer}, _) = Predicate.yield @{code test1};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test2};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test3};
  val SOME(@{code Void}, _) = Predicate.yield @{code test4};
  val SOME(@{code Void}, _) = Predicate.yield @{code test5};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test6};

definition testmb_isNull where "testmb_isNull = [classObject, classA], Map.empty([this] [↦] [Class ''A''])  mb_isNull :: _"
definition testmb_add where "testmb_add = [classObject, classA], Map.empty([this,''i''] [↦] [Class ''A'',Integer])  mb_add :: _"
definition testmb_mult_cond where "testmb_mult_cond = [classObject, classA], Map.empty([this,''j''] [↦] [Class ''A'',Integer])  mb_mult_cond :: _"
definition testmb_mult_block where "testmb_mult_block = [classObject, classA], Map.empty([this,''i'',''j'',''temp''] [↦] [Class ''A'',Integer,Integer,Integer])  mb_mult_block :: _"
definition testmb_mult where "testmb_mult = [classObject, classA], Map.empty([this,''i'',''j''] [↦] [Class ''A'',Integer,Integer])  mb_mult :: _"

ML_val val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_isNull};
  val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_add};
  val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_mult_cond};
  val SOME(@{code Void}, _) = Predicate.yield @{code testmb_mult_block};
  val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_mult};

definition test where "test = [classObject, classA], Map.empty  testExpr_ClassA :: _"

ML_val val SOME(@{code Integer}, _) = Predicate.yield @{code test};

end

Theory JVMState

(*  Title:      Jinja/JVM/JVMState.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

chapter ‹Jinja Virtual Machine \label{cha:jvm}›

section ‹State of the JVM›

theory JVMState imports "../Common/Objects" begin

subsection ‹Frame Stack›

type_synonym 
  pc = nat

type_synonym
  frame = "val list × val list × cname × mname × pc"
  ― ‹operand stack› 
  ― ‹registers (including this pointer, method parameters, and local variables)›
  ― ‹name of class where current method is defined›
  ― ‹parameter types›
  ― ‹program counter within frame›

subsection ‹Runtime State›

type_synonym
  jvm_state = "addr option × heap × frame list"  
  ― ‹exception flag, heap, frames›
  
end

Theory JVMInstructions

(*  Title:      HOL/MicroJava/JVM/JVMInstructions.thy

    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section ‹Instructions of the JVM›


theory JVMInstructions imports JVMState begin


datatype 
  instr = Load nat                  ― ‹load from local variable›
        | Store nat                 ― ‹store into local variable›
        | Push val                  ― ‹push a value (constant)›
        | New cname                 ― ‹create object›
        | Getfield vname cname      ― ‹Fetch field from object›
        | Putfield vname cname      ― ‹Set field in object›
        | Checkcast cname           ― ‹Check whether object is of given type›
        | Invoke mname nat          ― ‹inv. instance meth of an object›
        | Return                    ― ‹return from method›
        | Pop                       ― ‹pop top element from opstack›
        | IAdd                      ― ‹integer addition›
        | Goto int                  ― ‹goto relative address›
        | CmpEq                     ― ‹equality comparison›
        | IfFalse int               ― ‹branch if top of stack false›
        | Throw                     ― ‹throw top of stack as exception›

type_synonym
  bytecode = "instr list"

type_synonym
  ex_entry = "pc × pc × cname × pc × nat" 
  ― ‹start-pc, end-pc, exception type, handler-pc, remaining stack depth›

type_synonym
  ex_table = "ex_entry list"

type_synonym
  jvm_method = "nat × nat × bytecode × ex_table"
   ― ‹max stacksize›
   ― ‹number of local variables. Add 1 + no. of parameters to get no. of registers›
   ― ‹instruction sequence›
   ― ‹exception handler table›

type_synonym
  jvm_prog = "jvm_method prog" 

end

Theory JVMExecInstr

(*  Title:      HOL/MicroJava/JVM/JVMExecInstr.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹JVM Instruction Semantics›

theory JVMExecInstr
imports JVMInstructions JVMState "../Common/Exceptions"
begin

primrec
  exec_instr :: "[instr, jvm_prog, heap, val list, val list,
                  cname, mname, pc, frame list] => jvm_state"
where
exec_instr_Load:
 "exec_instr (Load n) P h stk loc C0 M0 pc frs = 
      (None, h, ((loc ! n) # stk, loc, C0, M0, pc+1)#frs)"

| "exec_instr (Store n) P h stk loc C0 M0 pc frs = 
      (None, h, (tl stk, loc[n:=hd stk], C0, M0, pc+1)#frs)"

| exec_instr_Push:
 "exec_instr (Push v) P h stk loc C0 M0 pc frs = 
      (None, h, (v # stk, loc, C0, M0, pc+1)#frs)"

| exec_instr_New:
 "exec_instr (New C) P h stk loc C0 M0 pc frs = 
  (case new_Addr h of
    None    (Some (addr_of_sys_xcpt OutOfMemory), h, (stk, loc, C0, M0, pc)#frs)
  | Some a  (None, h(ablank P C), (Addr a#stk, loc, C0, M0, pc+1)#frs))"

| "exec_instr (Getfield F C) P h stk loc C0 M0 pc frs = 
  (let v      = hd stk;
       xp'    = if v=Null then addr_of_sys_xcpt NullPointer else None;
       (D,fs) = the(h(the_Addr v))
   in (xp', h, (the(fs(F,C))#(tl stk), loc, C0, M0, pc+1)#frs))"

| "exec_instr (Putfield F C) P h stk loc C0 M0 pc frs = 
  (let v    = hd stk;
       r    = hd (tl stk);
       xp'  = if r=Null then addr_of_sys_xcpt NullPointer else None;
       a    = the_Addr r;
       (D,fs) = the (h a);
       h'  = h(a  (D, fs((F,C)  v)))
   in (xp', h', (tl (tl stk), loc, C0, M0, pc+1)#frs))"

| "exec_instr (Checkcast C) P h stk loc C0 M0 pc frs =
  (let v   = hd stk;
       xp' = if ¬cast_ok P C h v then addr_of_sys_xcpt ClassCast else None
   in (xp', h, (stk, loc, C0, M0, pc+1)#frs))"

| exec_instr_Invoke:
 "exec_instr (Invoke M n) P h stk loc C0 M0 pc frs =
  (let ps  = take n stk;
       r   = stk!n;
       xp' = if r=Null then addr_of_sys_xcpt NullPointer else None;
       C   = fst(the(h(the_Addr r)));
       (D,M',Ts,mxs,mxl0,ins,xt)= method P C M;
       f'  = ([],[r]@(rev ps)@(replicate mxl0 undefined),D,M,0)
   in (xp', h, f'#(stk, loc, C0, M0, pc)#frs))" 

| "exec_instr Return P h stk0 loc0 C0 M0 pc frs =
  (if frs=[] then (None, h, []) else 
   let v = hd stk0; 
       (stk,loc,C,m,pc) = hd frs;
       n = length (fst (snd (method P C0 M0)))
   in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs))"

| "exec_instr Pop P h stk loc C0 M0 pc frs = 
      (None, h, (tl stk, loc, C0, M0, pc+1)#frs)"

| "exec_instr IAdd P h stk loc C0 M0 pc frs =
  (let i2 = the_Intg (hd stk);
       i1 = the_Intg (hd (tl stk))
   in (None, h, (Intg (i1+i2)#(tl (tl stk)), loc, C0, M0, pc+1)#frs))"

| "exec_instr (IfFalse i) P h stk loc C0 M0 pc frs =
  (let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
   in (None, h, (tl stk, loc, C0, M0, pc')#frs))"

| "exec_instr CmpEq P h stk loc C0 M0 pc frs =
  (let v2 = hd stk;
       v1 = hd (tl stk)
   in (None, h, (Bool (v1=v2) # tl (tl stk), loc, C0, M0, pc+1)#frs))"

| exec_instr_Goto:
 "exec_instr (Goto i) P h stk loc C0 M0 pc frs =
      (None, h, (stk, loc, C0, M0, nat(int pc+i))#frs)"

| "exec_instr Throw P h stk loc C0 M0 pc frs =
  (let xp' = if hd stk = Null then addr_of_sys_xcpt NullPointer else the_Addr(hd stk)
   in (xp', h, (stk, loc, C0, M0, pc)#frs))"


lemma exec_instr_Store:
  "exec_instr (Store n) P h (v#stk) loc C0 M0 pc frs = 
  (None, h, (stk, loc[n:=v], C0, M0, pc+1)#frs)" 
  by simp

lemma exec_instr_Getfield:
 "exec_instr (Getfield F C) P h (v#stk) loc C0 M0 pc frs = 
  (let xp'    = if v=Null then addr_of_sys_xcpt NullPointer else None;
       (D,fs) = the(h(the_Addr v))
   in (xp', h, (the(fs(F,C))#stk, loc, C0, M0, pc+1)#frs))"
  by simp

lemma exec_instr_Putfield:
 "exec_instr (Putfield F C) P h (v#r#stk) loc C0 M0 pc frs = 
  (let xp'  = if r=Null then addr_of_sys_xcpt NullPointer else None;
       a    = the_Addr r;
       (D,fs) = the (h a);
       h'  = h(a  (D, fs((F,C)  v)))
   in (xp', h', (stk, loc, C0, M0, pc+1)#frs))"
  by simp

lemma exec_instr_Checkcast:
 "exec_instr (Checkcast C) P h (v#stk) loc C0 M0 pc frs =
  (let xp' = if ¬cast_ok P C h v then addr_of_sys_xcpt ClassCast else None
   in (xp', h, (v#stk, loc, C0, M0, pc+1)#frs))"
  by simp

lemma exec_instr_Return:
 "exec_instr Return P h (v#stk0) loc0 C0 M0 pc frs =
  (if frs=[] then (None, h, []) else 
   let (stk,loc,C,m,pc) = hd frs;
       n = length (fst (snd (method P C0 M0)))
   in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs))"
  by simp

lemma exec_instr_IPop:
 "exec_instr Pop P h (v#stk) loc C0 M0 pc frs = 
      (None, h, (stk, loc, C0, M0, pc+1)#frs)"
  by simp

lemma exec_instr_IAdd:
 "exec_instr IAdd P h (Intg i2 # Intg i1 # stk) loc C0 M0 pc frs =
      (None, h, (Intg (i1+i2)#stk, loc, C0, M0, pc+1)#frs)"
  by simp

lemma exec_instr_IfFalse:
 "exec_instr (IfFalse i) P h (v#stk) loc C0 M0 pc frs =
  (let pc' = if v = Bool False then nat(int pc+i) else pc+1
   in (None, h, (stk, loc, C0, M0, pc')#frs))"
  by simp

lemma exec_instr_CmpEq:
 "exec_instr CmpEq P h (v2#v1#stk) loc C0 M0 pc frs =
  (None, h, (Bool (v1=v2) # stk, loc, C0, M0, pc+1)#frs)"
  by simp

lemma exec_instr_Throw:
 "exec_instr Throw P h (v#stk) loc C0 M0 pc frs =
  (let xp' = if v = Null then addr_of_sys_xcpt NullPointer else the_Addr v
   in (xp', h, (v#stk, loc, C0, M0, pc)#frs))"
  by simp

end

Theory JVMExceptions

(*  Title:      HOL/MicroJava/JVM/JVMExceptions.thy
    Author:     Gerwin Klein, Martin Strecker
    Copyright   2001 Technische Universitaet Muenchen
*)

section ‹Exception handling in the JVM›

theory JVMExceptions imports JVMInstructions "../Common/Exceptions" begin

definition matches_ex_entry :: "'m prog  cname  pc  ex_entry  bool"
where
  "matches_ex_entry P C pc xcp 
                 let (s, e, C', h, d) = xcp in
                 s  pc  pc < e  P  C * C'"


primrec match_ex_table :: "'m prog  cname  pc  ex_table  (pc × nat) option"
where
  "match_ex_table P C pc []     = None"
| "match_ex_table P C pc (e#es) = (if matches_ex_entry P C pc e
                                   then Some (snd(snd(snd e)))
                                   else match_ex_table P C pc es)"

abbreviation
  ex_table_of :: "jvm_prog  cname  mname  ex_table" where
  "ex_table_of P C M == snd (snd (snd (snd (snd (snd(method P C M))))))"


primrec find_handler :: "jvm_prog  addr  heap  frame list  jvm_state"
where
  "find_handler P a h [] = (Some a, h, [])"
| "find_handler P a h (fr#frs) = 
       (let (stk,loc,C,M,pc) = fr in
        case match_ex_table P (cname_of h a) pc (ex_table_of P C M) of
          None  find_handler P a h frs
        | Some pc_d  (None, h, (Addr a # drop (size stk - snd pc_d) stk, loc, C, M, fst pc_d)#frs))"

end

Theory JVMExec

(*  Title:      HOL/MicroJava/JVM/JVMExec.thy
    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Program Execution in the JVM›

theory JVMExec
imports JVMExecInstr JVMExceptions
begin

abbreviation
  instrs_of :: "jvm_prog  cname  mname  instr list" where
  "instrs_of P C M == fst(snd(snd(snd(snd(snd(method P C M))))))"

fun exec :: "jvm_prog × jvm_state => jvm_state option" where ― ‹single step execution›
  "exec (P, xp, h, []) = None"

| "exec (P, None, h, (stk,loc,C,M,pc)#frs) =
  (let 
     i = instrs_of P C M ! pc;
     (xcpt', h', frs') = exec_instr i P h stk loc C M pc frs
   in Some(case xcpt' of
             None  (None,h',frs')
           | Some a  find_handler P a h ((stk,loc,C,M,pc)#frs)))"

| "exec (P, Some xa, h, frs) = None" 

― ‹relational view›
inductive_set
  exec_1 :: "jvm_prog  (jvm_state × jvm_state) set"
  and exec_1' :: "jvm_prog  jvm_state  jvm_state  bool" 
    ("_ / _ -jvm→1/ _" [61,61,61] 60)
  for P :: jvm_prog
where
  "P  σ -jvm→1 σ'  (σ,σ')  exec_1 P"
| exec_1I: "exec (P,σ) = Some σ'  P  σ -jvm→1 σ'"

― ‹reflexive transitive closure:›
definition exec_all :: "jvm_prog  jvm_state  jvm_state  bool"
    ("(_ / _ -jvm→/ _)" [61,61,61]60) where
(* FIXME exec_all → exec_star, also in Def.JVM *)
  exec_all_def1: "P  σ -jvm→ σ'  (σ,σ')  (exec_1 P)*"

notation (ASCII)
  exec_all  ("_ |-/ _ -jvm->/ _" [61,61,61]60)


lemma exec_1_eq:
  "exec_1 P = {(σ,σ'). exec (P,σ) = Some σ'}"
(*<*)by (auto intro: exec_1I elim: exec_1.cases)(*>*)

lemma exec_1_iff:
  "P  σ -jvm→1 σ' = (exec (P,σ) = Some σ')"
(*<*)by (simp add: exec_1_eq)(*>*)

lemma exec_all_def:
  "P  σ -jvm→ σ' = ((σ,σ')  {(σ,σ'). exec (P,σ) = Some σ'}*)"
(*<*)by (simp add: exec_all_def1 exec_1_eq)(*>*)

lemma jvm_refl[iff]: "P  σ -jvm→ σ"
(*<*)by(simp add: exec_all_def)(*>*)

lemma jvm_trans[trans]:
 " P  σ -jvm→ σ'; P  σ' -jvm→ σ''   P  σ -jvm→ σ''"
(*<*)by(simp add: exec_all_def)(*>*)

lemma jvm_one_step1[trans]:
 " P  σ -jvm→1 σ'; P  σ' -jvm→ σ''   P  σ -jvm→ σ''"
(*<*) by (simp add: exec_all_def1) (*>*)

lemma jvm_one_step2[trans]:
 " P  σ -jvm→ σ'; P  σ' -jvm→1 σ''   P  σ -jvm→ σ''"
(*<*) by (simp add: exec_all_def1) (*>*)

lemma exec_all_conf:
  " P  σ -jvm→ σ'; P  σ -jvm→ σ'' 
   P  σ' -jvm→ σ''  P  σ'' -jvm→ σ'"
(*<*)by(simp add: exec_all_def single_valued_def single_valued_confluent)(*>*)


lemma exec_all_finalD: "P  (x, h, []) -jvm→ σ  σ = (x, h, [])"
(*<*)
apply(simp only: exec_all_def)
apply(erule converse_rtranclE)
 apply simp
apply simp
done
(*>*)

lemma exec_all_deterministic:
  " P  σ -jvm→ (x,h,[]); P  σ -jvm→ σ'   P  σ' -jvm→ (x,h,[])"
(*<*)
apply(drule (1) exec_all_conf)
apply(blast dest!: exec_all_finalD)
done
(*>*)


text ‹
  The start configuration of the JVM: in the start heap, we call a 
  method m› of class C› in program P›. The 
  this› pointer of the frame is set to Null› to simulate
  a static method invokation.
›
definition start_state :: "jvm_prog  cname  mname  jvm_state" where
  "start_state P C M =
  (let (D,Ts,T,mxs,mxl0,b) = method P C M in
    (None, start_heap P, [([], Null # replicate mxl0 undefined, C, M, 0)]))"

end

Theory JVMDefensive

(*  Title:      HOL/MicroJava/JVM/JVMDefensive.thy
    Author:     Gerwin Klein
    Copyright   GPL
*)

section ‹A Defensive JVM›

theory JVMDefensive
imports JVMExec "../Common/Conform"
begin

text ‹
  Extend the state space by one element indicating a type error (or
  other abnormal termination)›
datatype 'a type_error = TypeError | Normal 'a

fun is_Addr :: "val  bool" where
  "is_Addr (Addr a)  True"
| "is_Addr v  False"

fun is_Intg :: "val  bool" where
  "is_Intg (Intg i)  True"
| "is_Intg v  False"

fun is_Bool :: "val  bool" where
  "is_Bool (Bool b)  True"
| "is_Bool v  False"

definition is_Ref :: "val  bool" where
  "is_Ref v  v = Null  is_Addr v"

primrec check_instr :: "[instr, jvm_prog, heap, val list, val list, 
                  cname, mname, pc, frame list]  bool" where
  check_instr_Load:
    "check_instr (Load n) P h stk loc C M0 pc frs = 
    (n < length loc)"

| check_instr_Store:
    "check_instr (Store n) P h stk loc C0 M0 pc frs = 
    (0 < length stk  n < length loc)"

| check_instr_Push:
    "check_instr (Push v) P h stk loc C0 M0 pc frs = 
    (¬is_Addr v)"

| check_instr_New:
    "check_instr (New C) P h stk loc C0 M0 pc frs = 
    is_class P C"

| check_instr_Getfield:
    "check_instr (Getfield F C) P h stk loc C0 M0 pc frs = 
    (0 < length stk  (C' T. P  C sees F:T in C')  
    (let (C', T) = field P C F; ref = hd stk in 
      C' = C  is_Ref ref  (ref  Null  
        h (the_Addr ref)  None  
        (let (D,vs) = the (h (the_Addr ref)) in 
          P  D * C  vs (F,C)  None  P,h  the (vs (F,C)) :≤ T))))" 

| check_instr_Putfield:
    "check_instr (Putfield F C) P h stk loc C0 M0 pc frs = 
    (1 < length stk  (C' T. P  C sees F:T in C') 
    (let (C', T) = field P C F; v = hd stk; ref = hd (tl stk) in 
      C' = C  is_Ref ref  (ref  Null  
        h (the_Addr ref)  None  
        (let D = fst (the (h (the_Addr ref))) in 
          P  D * C  P,h  v :≤ T))))" 

| check_instr_Checkcast:
    "check_instr (Checkcast C) P h stk loc C0 M0 pc frs =
    (0 < length stk  is_class P C  is_Ref (hd stk))"

| check_instr_Invoke:
    "check_instr (Invoke M n) P h stk loc C0 M0 pc frs =
    (n < length stk  is_Ref (stk!n)   
    (stk!n  Null  
      (let a = the_Addr (stk!n); 
           C = cname_of h a;
           Ts = fst (snd (method P C M))
      in h a  None  P  C has M  
         P,h  rev (take n stk) [:≤] Ts)))"
 
| check_instr_Return:
    "check_instr Return P h stk loc C0 M0 pc frs =
    (0 < length stk  ((0 < length frs)  
      (P  C0 has M0)     
      (let v = hd stk; 
           T = fst (snd (snd (method P C0 M0)))
       in P,h  v :≤ T)))"
 
| check_instr_Pop:
    "check_instr Pop P h stk loc C0 M0 pc frs = 
    (0 < length stk)"

| check_instr_IAdd:
    "check_instr IAdd P h stk loc C0 M0 pc frs =
    (1 < length stk  is_Intg (hd stk)  is_Intg (hd (tl stk)))"

| check_instr_IfFalse:
    "check_instr (IfFalse b) P h stk loc C0 M0 pc frs =
    (0 < length stk  is_Bool (hd stk)  0  int pc+b)"

| check_instr_CmpEq:
    "check_instr CmpEq P h stk loc C0 M0 pc frs =
    (1 < length stk)"

| check_instr_Goto:
    "check_instr (Goto b) P h stk loc C0 M0 pc frs =
    (0  int pc+b)"

| check_instr_Throw:
    "check_instr Throw P h stk loc C0 M0 pc frs =
    (0 < length stk  is_Ref (hd stk))"

definition check :: "jvm_prog  jvm_state  bool" where
  "check P σ = (let (xcpt, h, frs) = σ in
               (case frs of []  True | (stk,loc,C,M,pc)#frs'  
                P  C has M 
                (let (C',Ts,T,mxs,mxl0,ins,xt) = method P C M; i = ins!pc in
                 pc < size ins  size stk  mxs 
                 check_instr i P h stk loc C M pc frs')))"


definition exec_d :: "jvm_prog  jvm_state  jvm_state option type_error" where
  "exec_d P σ = (if check P σ then Normal (exec (P, σ)) else TypeError)"


inductive_set
  exec_1_d :: "jvm_prog  (jvm_state type_error × jvm_state type_error) set" 
  and exec_1_d' :: "jvm_prog  jvm_state type_error  jvm_state type_error  bool" 
                   ("_  _ -jvmd→1 _" [61,61,61]60)
  for P :: jvm_prog
where
  "P  σ -jvmd→1 σ'  (σ,σ')  exec_1_d P"
| exec_1_d_ErrorI: "exec_d P σ = TypeError  P  Normal σ -jvmd→1 TypeError"
| exec_1_d_NormalI: "exec_d P σ = Normal (Some σ')  P  Normal σ -jvmd→1 Normal σ'"

― ‹reflexive transitive closure:›
definition exec_all_d :: "jvm_prog  jvm_state type_error  jvm_state type_error  bool" 
    ("_  _ -jvmd→ _" [61,61,61]60) where
  exec_all_d_def1: "P  σ -jvmd→ σ'  (σ,σ')  (exec_1_d P)*"

notation (ASCII)
  "exec_all_d"  ("_ |- _ -jvmd-> _" [61,61,61]60)

lemma exec_1_d_eq:
  "exec_1_d P = {(s,t). σ. s = Normal σ  t = TypeError  exec_d P σ = TypeError}  
                {(s,t). σ σ'. s = Normal σ  t = Normal σ'  exec_d P σ = Normal (Some σ')}"
by (auto elim!: exec_1_d.cases intro!: exec_1_d.intros)


declare split_paired_All [simp del]
declare split_paired_Ex [simp del]

lemma if_neq [dest!]:
  "(if P then A else B)  B  P"
  by (cases P, auto)

lemma exec_d_no_errorI [intro]:
  "check P σ  exec_d P σ  TypeError"
  by (unfold exec_d_def) simp

theorem no_type_error_commutes:
  "exec_d P σ  TypeError  exec_d P σ = Normal (exec (P, σ))"
  by (unfold exec_d_def, auto)


lemma defensive_imp_aggressive:
  "P  (Normal σ) -jvmd→ (Normal σ')  P  σ -jvm→ σ'"
(*<*)
proof -
  have "x y. P  x -jvmd→ y  σ σ'. x = Normal σ  y = Normal σ'   P  σ -jvm→ σ'"
    apply (unfold exec_all_d_def1)
    apply (erule rtrancl_induct)
     apply (simp add: exec_all_def)
    apply (fold exec_all_d_def1)
    apply simp
    apply (intro allI impI)
    apply (erule exec_1_d.cases, simp)
    apply (simp add: exec_all_def exec_d_def split: type_error.splits if_split_asm)
    apply (rule rtrancl_trans, assumption)
    apply blast
    done
  moreover
  assume "P  (Normal σ) -jvmd→ (Normal σ')" 
  ultimately
  show "P  σ -jvm→ σ'" by blast
qed
(*>*)

end

Theory JVMListExample

(*  Title:      Jinja/JVM/JVMListExample.thy
    Author:     Stefan Berghofer, Gerwin Klein
*)

section ‹Example for generating executable code from JVM semantics \label{sec:JVMListExample}›

theory JVMListExample
imports
  "../Common/SystemClasses"
  JVMExec
  "HOL-Library.Code_Target_Numeral"
begin

definition list_name :: string
where
  "list_name == ''list''"

definition test_name :: string
where
  "test_name == ''test''"

definition val_name :: string
where
  "val_name == ''val''"

definition next_name :: string
where
  "next_name == ''next''"

definition append_name :: string
where
  "append_name == ''append''"

definition makelist_name :: string
where
  "makelist_name == ''makelist''"

definition append_ins :: bytecode
where
  "append_ins == 
       [Load 0,
        Getfield next_name list_name,
        Load 0,
        Getfield next_name list_name,
        Push Null,
        CmpEq,
        IfFalse 7,
        Pop,
        Load 0,
        Load 1,
        Putfield next_name list_name,
        Push Unit,
        Return,
        Load 1,       
        Invoke append_name 1,
        Return]"

definition list_class :: "jvm_method class"
where
  "list_class ==
    (Object,
     [(val_name, Integer), (next_name, Class list_name)],
     [(append_name, [Class list_name], Void,
        (3, 0, append_ins, [(1, 2, NullPointer, 7, 0)]))])"

definition make_list_ins :: bytecode
where
  "make_list_ins ==
       [New list_name,
        Store 0,
        Load 0,
        Push (Intg 1),
        Putfield val_name list_name,
        New list_name,
        Store 1,
        Load 1,
        Push (Intg 2),
        Putfield val_name list_name,
        New list_name,
        Store 2,
        Load 2,
        Push (Intg 3),
        Putfield val_name list_name,
        Load 0,
        Load 1,
        Invoke append_name 1,
        Pop,
        Load 0,
        Load 2,
        Invoke append_name 1,
        Return]"

definition test_class :: "jvm_method class"
where
  "test_class ==
    (Object, [],
     [(makelist_name, [], Void, (3, 2, make_list_ins, []))])"

definition E :: jvm_prog
where
  "E == SystemClasses @ [(list_name, list_class), (test_name, test_class)]"

definition undefined_cname :: cname 
  where [code del]: "undefined_cname = undefined"
declare undefined_cname_def[symmetric, code_unfold]
code_printing constant undefined_cname  (SML) "object"

definition undefined_val :: val
  where [code del]: "undefined_val = undefined"
declare undefined_val_def[symmetric, code_unfold]
code_printing constant undefined_val  (SML) "Unit"

lemmas [code_unfold] = SystemClasses_def [unfolded ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def]

definition "test = exec (E, start_state E test_name makelist_name)"

ML_val @{code test};
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);
  @{code exec} (@{code E}, @{code the} it);

  val SOME (_, (h, _)) = it;
  if snd (@{code the} (h (@{code nat_of_integer} 3))) (@{code val_name}, @{code list_name}) =
    SOME (@{code Intg} (@{code int_of_integer} 1)) then () else error "wrong result";
  if snd (@{code the} (h (@{code nat_of_integer} 3))) (@{code next_name}, @{code list_name}) =
    SOME (@{code Addr} (@{code nat_of_integer} 4)) then () else error "wrong result";
  if snd (@{code the} (h (@{code nat_of_integer} 4))) (@{code val_name}, @{code list_name}) =
    SOME (@{code Intg} (@{code int_of_integer} 2)) then () else error "wrong result";
  if snd (@{code the} (h (@{code nat_of_integer} 4))) (@{code next_name}, @{code list_name}) =
    SOME (@{code Addr} (@{code nat_of_integer} 5)) then () else error "wrong result";
  if snd (@{code the} (h (@{code nat_of_integer} 5))) (@{code val_name}, @{code list_name}) =
    SOME (@{code Intg} (@{code int_of_integer} 3)) then () else error "wrong result";
  if snd (@{code the} (h (@{code nat_of_integer} 5))) (@{code next_name}, @{code list_name}) =
    SOME @{code Null} then () else error "wrong result";

end

Theory Semilat

(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Semilattices.
*)

chapter ‹Bytecode Verifier \label{cha:bv}›

section ‹Semilattices›

theory Semilat
imports Main "HOL-Library.While_Combinator"
begin

type_synonym 'a ord    = "'a  'a  bool"
type_synonym 'a binop  = "'a  'a  'a"
type_synonym 'a sl     = "'a set × 'a ord × 'a binop"

definition lesub :: "'a  'a ord  'a  bool"
  where "lesub x r y  r x y"

definition lesssub :: "'a  'a ord  'a  bool"
  where "lesssub x r y  lesub x r y  x  y"

definition plussub :: "'a  ('a  'b  'c)  'b  'c"
  where "plussub x f y = f x y"

notation (ASCII)
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)

notation
  "lesub"  ("(_ /⊑⇘_ _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /⊏⇘_ _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /⊔⇘_ _)" [65, 0, 66] 65)

(* allow \<sub> instead of \<bsub>..\<esub> *)
abbreviation (input)
  lesub1 :: "'a  'a ord  'a  bool" ("(_ /⊑⇩_ _)" [50, 1000, 51] 50)
  where "x ⊑⇩r y == xr y"

abbreviation (input)
  lesssub1 :: "'a  'a ord  'a  bool" ("(_ /⊏⇩_ _)" [50, 1000, 51] 50)
  where "x ⊏⇩r y == xr y"

abbreviation (input)
  plussub1 :: "'a  ('a  'b  'c)  'b  'c" ("(_ /⊔⇩_ _)" [65, 1000, 66] 65)
  where "x ⊔⇩f y == xf y"

definition ord :: "('a × 'a) set  'a ord"
where
  "ord r = (λx y. (x,y)  r)"

definition order :: "'a ord  bool"
where
  "order r  (x. x ⊑⇩r x)  (x y. x ⊑⇩r y  y ⊑⇩r x  x=y)  (x y z. x ⊑⇩r y  y ⊑⇩r z  x ⊑⇩r z)"

definition top :: "'a ord  'a  bool"
where
  "top r T  (x. x ⊑⇩r T)"
  
definition acc :: "'a ord  bool"
where
  "acc r  wf {(y,x). x ⊏⇩r y}"

definition closed :: "'a set  'a binop  bool"
where
  "closed A f  (xA. yA. x ⊔⇩f y  A)"

definition semilat :: "'a sl  bool"
where
  "semilat = (λ(A,r,f). order r  closed A f  
                       (xA. yA. x ⊑⇩r x ⊔⇩f y) 
                       (xA. yA. y ⊑⇩r x ⊔⇩f y) 
                       (xA. yA. zA. x ⊑⇩r z  y ⊑⇩r z  x ⊔⇩f y ⊑⇩r z))"

definition is_ub :: "('a × 'a) set  'a  'a  'a  bool"
where
  "is_ub r x y u  (x,u)r  (y,u)r"

definition is_lub :: "('a × 'a) set  'a  'a  'a  bool"
where
  "is_lub r x y u  is_ub r x y u  (z. is_ub r x y z  (u,z)r)"

definition some_lub :: "('a × 'a) set  'a  'a  'a"
where
  "some_lub r x y = (SOME z. is_lub r x y z)"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r  x ⊑⇩r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: " order r; x ⊑⇩r y; y ⊑⇩r x   x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: " order r; x ⊑⇩r y; y ⊑⇩r z   x ⊑⇩r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r  ¬ x ⊏⇩r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: " order r; x ⊏⇩r y; y ⊏⇩r z   x ⊏⇩r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T  x ⊑⇩r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: " order r; top r T   (T ⊑⇩r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f)  order r  closed A f  
                 (xA. yA. x ⊑⇩r x ⊔⇩f y)  
                 (xA. yA. y ⊑⇩r x ⊔⇩f y)  
                 (xA. yA. zA. x ⊑⇩r z  y ⊑⇩r z  x ⊔⇩f y ⊑⇩r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: " closed A f; xA; yA   x ⊔⇩f y  A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "x  A; y  A   x ⊔⇩f y  A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x ⊑⇩r x" by simp

lemma (in Semilat) antisym_r [intro?]: " x ⊑⇩r y; y ⊑⇩r x   x = y"
  (*<*) by (rule order_antisym) auto (*>*)
  
lemma (in Semilat) trans_r [trans, intro?]: "x ⊑⇩r y; y ⊑⇩r z  x ⊑⇩r z"
  (*<*) by (auto intro: order_trans) (*>*)
  
lemma (in Semilat) ub1 [simp, intro?]: " x  A; y  A   x ⊑⇩r x ⊔⇩f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: " x  A; y  A   y ⊑⇩r x ⊔⇩f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  " x ⊑⇩r z; y ⊑⇩r z; x  A; y  A; z  A   x ⊔⇩f y ⊑⇩r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  " x  A; y  A; z  A   (x ⊔⇩f y ⊑⇩r z) = (x ⊑⇩r z  y ⊑⇩r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged:
  assumes "x  A" and "y  A"
  shows "x ⊑⇩r y  x ⊔⇩f y = y" (is "?P  ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub2)
next
  assume ?Q
  then have "y = xf y" by simp
  moreover from assms have "xr xf y" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2:
  assumes "x  A" and "y  A"
  shows "x ⊑⇩r y  y ⊔⇩f x = y" (is "?P  ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub1)
next
  assume ?Q
  then have "y = yf x" by simp
  moreover from assms have "xr yf x" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a  A" and b: "b  A" and c: "c  A"
  shows "a ⊔⇩f (b ⊔⇩f c) = a ⊔⇩f b ⊔⇩f c"
(*<*)
proof -
  from a b have ab: "a ⊔⇩f b  A" ..
  from this c have abc: "(a ⊔⇩f b) ⊔⇩f c  A" ..
  from b c have bc: "b ⊔⇩f c  A" ..
  from a this have abc': "a ⊔⇩f (b ⊔⇩f c)  A" ..

  show ?thesis
  proof    
    show "a ⊔⇩f (b ⊔⇩f c) ⊑⇩r (a ⊔⇩f b) ⊔⇩f c"
    proof -
      from a b have "a ⊑⇩r a ⊔⇩f b" .. 
      also from ab c have " ⊑⇩r  ⊔⇩f c" ..
      finally have "a<": "a ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
      from a b have "b ⊑⇩r a ⊔⇩f b" ..
      also from ab c have " ⊑⇩r  ⊔⇩f c" ..
      finally have "b<": "b ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
      from ab c have "c<": "c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..    
      from "b<" "c<" b c abc have "b ⊔⇩f c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a ⊔⇩f b) ⊔⇩f c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" 
    proof -
      from b c have "b ⊑⇩r b ⊔⇩f c" .. 
      also from a bc have " ⊑⇩r a ⊔⇩f " ..
      finally have "b<": "b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
      from b c have "c ⊑⇩r b ⊔⇩f c" ..
      also from a bc have " ⊑⇩r a ⊔⇩f " ..
      finally have "c<": "c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
      from a bc have "a<": "a ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
      from "a<" "b<" a b abc' have "a ⊔⇩f b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "a  A; b  A  a ⊔⇩f b ⊑⇩r b ⊔⇩f a"
(*<*)
proof -
  assume a: "a  A" and b: "b  A"  
  from b a have "a ⊑⇩r b ⊔⇩f a" .. 
  moreover from b a have "b ⊑⇩r b ⊔⇩f a" ..
  moreover note a b
  moreover from b a have "b ⊔⇩f a  A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "a  A; b  A  a ⊔⇩f b = b ⊔⇩f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u  is_ub r x y u  (z. is_ub r x y z  (u,z)  r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  " (x,u)  r; (y,u)  r   is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u  (x,u)  r  (y,u)  r"
  (*<*) by (simp add: is_ub_def) (*>*)


lemma is_lub_bigger1 [iff]:  
  "is_lub (r^* ) x y y = ((x,y)r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast 
done
(*>*)

lemma extend_lub:
  " single_valued r; is_lub (r^* ) x y u; (x',x)  r  
   v. is_lub (r^* ) x' y v"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x)  r^*")
 apply (case_tac "(y,x')  r^*")
  apply blast
 apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
 apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl 
             elim: converse_rtranclE dest: single_valuedD)
done
(*>*)

lemma single_valued_has_lubs [rule_format]:
  " single_valued r; (x,u)  r^*   (y. (y,u)  r^*  
  (z. is_lub (r^* ) x y z))"
(*<*)
apply (erule converse_rtrancl_induct)
 apply clarify
 apply (erule converse_rtrancl_induct)
  apply blast
 apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
(*>*)

lemma some_lub_conv:
  " acyclic r; is_lub (r^* ) x y u   some_lub (r^* ) x y = u"
(*<*)
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
 apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  " single_valued r; acyclic r; (x,u)r^*; (y,u)r^*  
   is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection‹An executable lub-finder›

definition exec_lub :: "('a * 'a) set  ('a  'a)  'a binop"
where
  "exec_lub r f x y = while (λz. (x,z)  r*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "acyclic r; single_valued r; (x,y)  r*
   finite (r  {a. (x, a)  r*} × {b. (b, y)  r*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r  {a. (x,a)  r*} × {b. (b,y)  r*} =
                   insert (x,x') (r  {a. (x', a)  r*} × {b. (b, y)  r*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)


lemma exec_lub_conv:
  " acyclic r; x y. (x,y)  r  f x = y; is_lub (r*) x y u  
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "λz. (y,z)  r*  (z,u)  r*" and
               r = "(r  {(a,b). (y,a)  r*  (b,u)  r*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s)  r*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  " single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; x y. (x,y)  r  f x = y 
   is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end

Theory Err

(*  Title:      HOL/MicroJava/BV/Err.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

The error type.
*)

section ‹The Error Type›

theory Err
imports Semilat
begin

datatype 'a err = Err | OK 'a

type_synonym 'a ebinop = "'a  'a  'a err"
type_synonym 'a esl = "'a set × 'a ord × 'a ebinop"

primrec ok_val :: "'a err  'a"
where
  "ok_val (OK x) = x"

definition lift :: "('a  'b err)  ('a err  'b err)"
where
  "lift f e = (case e of Err  Err | OK x  f x)"

definition lift2 :: "('a  'b  'c err)  'a err  'b err  'c err"
where
  "lift2 f e1 e2 =
  (case e1 of Err   Err | OK x  (case e2 of Err  Err | OK y  f x y))"

definition le :: "'a ord  'a err ord"
where
  "le r e1 e2 =
  (case e2 of Err  True | OK y  (case e1 of Err  False | OK x  x ⊑⇩r y))"

definition sup :: "('a  'b  'c)  ('a err  'b err  'c err)"
where
  "sup f = lift2 (λx y. OK (x ⊔⇩f y))"

definition err :: "'a set  'a err set"
where
  "err A = insert Err {OK x|x. xA}"

definition esl :: "'a sl  'a esl"
where
  "esl = (λ(A,r,f). (A, r, λx y. OK(f x y)))"

definition sl :: "'a esl  'a err sl"
where
  "sl = (λ(A,r,f). (err A, le r, lift2 f))"

abbreviation
  err_semilat :: "'a esl  bool" where
  "err_semilat L == semilat(sl L)"

primrec strict  :: "('a  'b err)  ('a err  'b err)"
where
  "strict f Err    = Err"
| "strict f (OK x) = f x"

lemma err_def':
  "err A = insert Err {x. yA. x = OK y}"
(*<*)
proof -
  have eq: "err A = insert Err {x. yA. x = OK y}"
    by (unfold err_def) blast
  show "err A = insert Err {x. yA. x = OK y}" by (simp add: eq)
qed
(*>*)

lemma strict_Some [simp]: 
  "(strict f x = OK y) = (z. x = OK z  f z = OK y)"
(*<*) by (cases x, auto) (*>*)

lemma not_Err_eq: "(x  Err) = (a. x = OK a)" 
(*<*) by (cases x) auto (*>*)

lemma not_OK_eq: "(y. x  OK y) = (x = Err)"
(*<*) by (cases x) auto   (*>*)

lemma unfold_lesub_err: "e1le r e2 = le r e1 e2"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_err_refl: "x. x ⊑⇩r x  ele r e"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: err.split)
done 
(*>*)

lemma le_err_trans [rule_format]:
  "order r  e1le r e2  e2le r e3  e1le r e3"
(*<*)
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_err_antisym [rule_format]:
  "order r  e1le r e2  e2le r e1  e1=e2"
(*<*)
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_antisym)
done 
(*>*)

lemma OK_le_err_OK: "(OK xle r OK y) = (x ⊑⇩r y)"
(*<*) by (simp add: unfold_lesub_err le_def) (*>*)

lemma order_le_err [iff]: "order(le r) = order r"
(*<*)
apply (rule iffI)
 apply (subst order_def)
 apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
              intro: order_trans OK_le_err_OK [THEN iffD1])
apply (subst order_def)
apply (blast intro: le_err_refl le_err_trans le_err_antisym
             dest: order_refl)
done 
(*>*)

lemma le_Err [iff]: "ele r Err"
(*<*) by (simp add: unfold_lesub_err le_def) (*>*)

lemma Err_le_conv [iff]: "Err ⊑le r e  = (e = Err)"
(*<*) by (simp add: unfold_lesub_err le_def  split: err.split) (*>*)

lemma le_OK_conv [iff]: "ele r OK x  =  (y. e = OK y  y ⊑⇩r x)"
(*<*) by (simp add: unfold_lesub_err le_def split: err.split) (*>*)

lemma OK_le_conv: "OK xle r e = (e = Err  (y. e = OK y  x ⊑⇩r y))"
(*<*) by (simp add: unfold_lesub_err le_def split: err.split) (*>*)

lemma top_Err [iff]: "top (le r) Err"
(*<*) by (simp add: top_def) (*>*)

lemma OK_less_conv [rule_format, iff]:
  "OK xle r e = (e=Err  (y. e = OK y  x ⊏⇩r y))"
(*<*) by (simp add: lesssub_def lesub_def le_def split: err.split) (*>*)

lemma not_Err_less [rule_format, iff]: "¬(Err ⊏le r x)"
(*<*) by (simp add: lesssub_def lesub_def le_def split: err.split) (*>*)

lemma semilat_errI [intro]: assumes "Semilat A r f"
shows "semilat(err A, le r, lift2(λx y. OK(f x y)))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
    apply(insert semilat)
    apply (simp only: semilat_Def closed_def plussub_def lesub_def 
              lift2_def le_def)
    apply (simp add: err_def' split: err.split)
    done
qed
(*>*)

lemma err_semilat_eslI_aux:
assumes "Semilat A r f" shows "err_semilat(esl(A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
    apply (unfold sl_def esl_def)
    apply (simp add: semilat_errI [OF ‹Semilat A r f])
    done
qed
(*>*)

lemma err_semilat_eslI [intro, simp]:
  "semilat L  err_semilat (esl L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
apply (simp add: err_semilat_eslI_aux split_tupled_all)
done (*>*)

lemma acc_err [simp, intro!]:  "acc r  acc(le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: err.split)
apply clarify
apply (case_tac "Err : Q")
 apply blast
apply (erule_tac x = "{a . OK a : Q}" in allE)
apply (case_tac "x")
 apply fast
apply blast
done 
(*>*)

lemma Err_in_err [iff]: "Err : err A"
(*<*) by (simp add: err_def') (*>*)

lemma Ok_in_err [iff]: "(OK x  err A) = (xA)"
(*<*) by (auto simp add: err_def') (*>*)

subsection ‹lift›

lemma lift_in_errI:
  " e  err S; xS. e = OK x  f x  err S   lift f e  err S"
(*<*)
apply (unfold lift_def)
apply (simp split: err.split)
apply blast
done 
(*>*)

lemma Err_lift2 [simp]: "Err ⊔lift2 f x = Err"
(*<*) by (simp add: lift2_def plussub_def) (*>*)

lemma lift2_Err [simp]: "xlift2 f Err = Err"
(*<*) by (simp add: lift2_def plussub_def split: err.split) (*>*)

lemma OK_lift2_OK [simp]: "OK xlift2 f OK y = x ⊔⇩f y"
(*<*) by (simp add: lift2_def plussub_def split: err.split) (*>*)


subsection ‹sup›

lemma Err_sup_Err [simp]: "Err ⊔sup f x = Err"
(*<*) by (simp add: plussub_def sup_def lift2_def) (*>*)

lemma Err_sup_Err2 [simp]: "xsup f Err = Err"
(*<*) by (simp add: plussub_def sup_def lift2_def split: err.split) (*>*)

lemma Err_sup_OK [simp]: "OK xsup f OK y = OK (x ⊔⇩f y)"
(*<*) by (simp add: plussub_def sup_def lift2_def) (*>*)

lemma Err_sup_eq_OK_conv [iff]:
  "(sup f ex ey = OK z) = (x y. ex = OK x  ey = OK y  f x y = z)"
(*<*)
apply (unfold sup_def lift2_def plussub_def)
apply (rule iffI)
 apply (simp split: err.split_asm)
apply clarify
apply simp
done
(*>*)

lemma Err_sup_eq_Err [iff]: "(sup f ex ey = Err) = (ex=Err  ey=Err)"
(*<*)
apply (unfold sup_def lift2_def plussub_def)
apply (simp split: err.split)
done 
(*>*)

subsection ‹semilat (err A) (le r) f›

lemma semilat_le_err_Err_plus [simp]:
  " x err A; semilat(err A, le r, f)   Err ⊔⇩f x = Err"
(*<*) by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro] 
                   Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro]) (*>*)

lemma semilat_le_err_plus_Err [simp]:
  " x err A; semilat(err A, le r, f)   x ⊔⇩f Err = Err"
(*<*) by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro]
                   Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro]) (*>*)

lemma semilat_le_err_OK1:
  " xA; yA; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z  
   x ⊑⇩r z"
(*<*)
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub1 [OF Semilat.intro])
done
(*>*)

lemma semilat_le_err_OK2:
  " xA; yA; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z  
   y ⊑⇩r z"
(*<*)
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub2 [OF Semilat.intro])
done
(*>*)

lemma eq_order_le:
  " x=y; order r   x ⊑⇩r y"
(*<*)
apply (unfold order_def)
apply blast
done
(*>*)

lemma OK_plus_OK_eq_Err_conv [simp]:
  assumes "xA"  "yA"  "semilat(err A, le r, fe)"
  shows "(OK xfe OK y = Err) = (¬(zA. x ⊑⇩r z  y ⊑⇩r z))"
(*<*)
proof -
  have plus_le_conv3: "A x y z f r. 
     semilat (A,r,f); x ⊔⇩f y ⊑⇩r z; xA; yA; zA  
     x ⊑⇩r z  y ⊑⇩r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "OK xfe OK y")
   apply assumption
  apply (rename_tac z)
  apply (subgoal_tac "OK z err A")
  apply (drule eq_order_le)
    apply (erule Semilat.orderI [OF Semilat.intro])
   apply (blast dest: plus_le_conv3) 
  apply (erule subst)
  apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
  done 
qed
(*>*)

subsection ‹semilat (err(Union AS))›

(* FIXME? *)
lemma all_bex_swap_lemma [iff]:
  "(x. (yA. x = f y)  P x) = (yA. P(f y))"
(*<*) by blast (*>*)

lemma closed_err_Union_lift2I: 
  " AAS. closed (err A) (lift2 f); AS  {}; 
      AAS.BAS. AB  (aA.bB. a ⊔⇩f b = Err)  
   closed (err(Union AS)) (lift2 f)"
(*<*)
apply (unfold closed_def err_def')
apply simp
apply clarify
apply simp
apply fast
done 
(*>*)

text ‹
  If @{term "AS = {}"} the thm collapses to
  @{prop "order r  closed {Err} f  Err ⊔⇩f Err = Err"}
  which may not hold 
›
lemma err_semilat_UnionI:
  " AAS. err_semilat(A, r, f); AS  {}; 
      AAS.BAS. AB  (aA.bB. ¬a ⊑⇩r b  a ⊔⇩f b = Err)  
   err_semilat(Union AS, r, f)"
(*<*)
apply (unfold semilat_def sl_def)
apply (simp add: closed_err_Union_lift2I)
apply (rule conjI)
 apply blast
apply (simp add: err_def')
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply clarify
apply (rename_tac A ya yb B yd z C c a b)
apply (case_tac "A = B")
 apply (case_tac "A = C")
  apply simp
 apply simp
apply (case_tac "B = C")
 apply simp
apply simp
done 
(*>*)

end

Theory Opt

(*  Title:      HOL/MicroJava/BV/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

More about options.
*)

section ‹More about Options›

theory Opt imports Err begin

definition le :: "'a ord  'a option ord"
where
  "le r o1 o2 =
  (case o2 of None  o1=None | Some y  (case o1 of None  True | Some x  x ⊑⇩r y))"

definition opt :: "'a set  'a option set"
where
  "opt A = insert None {Some y |y. y  A}"

definition sup :: "'a ebinop  'a option ebinop"
where
  "sup f o1 o2 =  
  (case o1 of None  OK o2 
           | Some x  (case o2 of None  OK o1
                                 | Some y  (case f x y of Err  Err | OK z  OK (Some z))))"

definition esl :: "'a esl  'a option esl"
where
  "esl = (λ(A,r,f). (opt A, le r, sup f))"


lemma unfold_le_opt:
  "o1le r o2 = 
  (case o2 of None  o1=None | 
              Some y  (case o1 of None  True | Some x  x ⊑⇩r y))"
(*<*)
apply (unfold lesub_def le_def)
apply (rule refl)
done
(*>*)

lemma le_opt_refl: "order r  xle r x"
(*<*) by (simp add: unfold_le_opt split: option.split) (*<*)

lemma le_opt_trans [rule_format]:
  "order r  xle r y  yle r z  xle r z"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_opt_antisym [rule_format]:
  "order r  xle r y  yle r x  x=y"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
(*>*)

lemma order_le_opt [intro!,simp]: "order r  order(le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done 
(*>*)

lemma None_bot [iff]:  "None ⊑le r ox"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done 
(*>*)

lemma Some_le [iff]: "(Some xle r z) = (y. z = Some y  x ⊑⇩r y)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done 
(*>*)

lemma le_None [iff]: "(xle r None) = (x = None)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done 
(*>*)

lemma OK_None_bot [iff]: "OK None ⊑Err.le (le r) x"
(*<*) by (simp add: lesub_def Err.le_def le_def split: option.split err.split) (*>*)

lemma sup_None1 [iff]: "xsup f None = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma sup_None2 [iff]: "None ⊔sup f x = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma None_in_opt [iff]: "None  opt A"
(*<*) by (simp add: opt_def) (*>*)

lemma Some_in_opt [iff]: "(Some x  opt A) = (x  A)"
(*<*) by (unfold opt_def) auto (*>*)

lemma semilat_opt [intro, simp]:
  "err_semilat L  err_semilat (Opt.esl L)"
(*<*)
proof -
  assume s: "err_semilat L" 
  obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
  let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
  from s obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "x?A0. y?A0. x?r0 x?f0 y" and
    ub2: "x?A0. y?A0. y?r0 x?f0 y" and
    lub: "x?A0. y?A0. z?A0. x?r0 z  y?r0 z  x?f0 y?r0 z"
    by (unfold semilat_def sl_def) simp

  let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"

  from ord have "order ?r" by simp
  moreover
  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y assume x: "x  ?A" and y: "y  ?A" 

    { fix a b assume ab: "x = OK a" "y = OK b"
      with x have a: "c. a = Some c  c  A" by (clarsimp simp add: opt_def)
      from ab y have b: "d. b = Some d  d  A" by (clarsimp simp add: opt_def)      
      { fix c d assume "a = Some c" "b = Some d"
        with ab x y have "c  A & d  A" by (simp add: err_def opt_def Bex_def)
        with clo have "f c d  err A" 
          by (simp add: closed_def plussub_def err_def' lift2_def)
        moreover fix z assume "f c d = OK z"
        ultimately have "z  A" by simp
      } note f_closed = this    
      have "sup f a b  ?A"
      proof (cases a)
        case None thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }
    thus "x?f y  ?A" by (simp add: plussub_def lift2_def split: err.split)
  qed
  moreover
  { fix a b c assume "a  opt A" and "b  opt A" and "asup f b = OK c" 
    moreover from ord have "order r" by simp
    moreover
    { fix x y z assume "x  A" and "y  A" 
      hence "OK x  err A  OK y  err A" by simp
      with ub1 ub2
      have "(OK x)Err.le r (OK x)lift2 f (OK y) 
            (OK y)Err.le r (OK x)lift2 f (OK y)"
        by blast
      moreover assume "x ⊔⇩f y = OK z"
      ultimately have "x ⊑⇩r z  y ⊑⇩r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately have "ale r c  ble r c"
      by (auto simp add: sup_def le_def lesub_def plussub_def 
               dest: order_refl split: option.splits err.splits)
  }     
  hence "(x?A. y?A. x?r x?f y)  (x?A. y?A. y?r x?f y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
  moreover
  have "x?A. y?A. z?A. x?r z  y?r z  x?f y?r z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x  ?A"   "y  ?A"   "z  ?A"
    assume xz: "x?r z" and yz: "y?r z"
    { fix a b c assume ok: "x = OK a"  "y = OK b"  "z = OK c"
      { fix d e g  assume some: "a = Some d"  "b = Some e"  "c = Some g"
        with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A"  by simp
        with lub  
        have " OK dErr.le r OK g; OK eErr.le r OK g   OK dlift2 f OK eErr.le r OK g"
          by blast
        hence " d ⊑⇩r g; e ⊑⇩r g   y. d ⊔⇩f e = OK y  y ⊑⇩r g" by simp
        with ok some xyz xz yz have "x?f y?r z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]
      from ok xyz xz yz have "x?f y?r z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }    
    with xyz xz yz show "x?f y?r z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed
  ultimately show "err_semilat (Opt.esl L)"
    by (unfold semilat_def esl_def sl_def) simp
qed 
(*>*)

lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
(*<*)
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done 
(*>*)

lemma Top_le_conv:  " order r; top r T   (T ⊑⇩r x) = (x = T)"
(*<*)
apply (unfold top_def)
apply (blast intro: order_antisym)
done 
(*>*)


lemma acc_le_optI [intro!]: "acc r  acc(le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "a. Some a  Q")
 apply (erule_tac x = "{a . Some a  Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done 
(*>*)

lemma map_option_in_optionI:
  " ox  opt S; xS. ox = Some x  f x  S  
   map_option f ox  opt S"
(*<*)
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done 
(*>*)

end

Theory Product

(*  Title:      HOL/MicroJava/BV/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Products as semilattices.
*)

section ‹Products as Semilattices›

theory Product
imports Err
begin

definition le :: "'a ord  'b ord  ('a × 'b) ord"
where
  "le rA rB = (λ(a1,b1) (a2,b2). a1rA a2  b1rB b2)"

definition sup :: "'a ebinop  'b ebinop  ('a × 'b) ebinop"
where
  "sup f g = (λ(a1,b1)(a2,b2). Err.sup Pair (a1 ⊔⇩f a2) (b1 ⊔⇩g b2))"

definition esl :: "'a esl  'b esl  ('a × 'b ) esl"
where
  "esl = (λ(A,rA,fA) (B,rB,fB). (A × B, le rA rB, sup fA fB))"

abbreviation
  lesubprod :: "'a × 'b  ('a  'a  bool)  ('b  'b  bool)  'a × 'b  bool"
    ("(_ /⊑'(_,_') _)" [50, 0, 0, 51] 50) where
  "p ⊑(rA,rB) q == pProduct.le rA rB q"

(*<*)
notation
  lesubprod  ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
(*>*)

lemma unfold_lesub_prod: "x ⊑(rA,rB) y = le rA rB x y"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_prod_Pair_conv [iff]: "((a1,b1) ⊑(rA,rB) (a2,b2)) = (a1rA a2 & b1rB b2)"
(*<*) by (simp add: lesub_def le_def) (*>*)

lemma less_prod_Pair_conv:
  "((a1,b1)Product.le rA rB (a2,b2)) = 
  (a1rA a2 & b1rB b2 | a1rA a2 & b1rB b2)"
(*<*)
apply (unfold lesssub_def)
apply simp
apply blast
done
(*>*)

lemma order_le_prod [iff]: "order(Product.le rA rB) = (order rA & order rB)"
(*<*)
apply (unfold order_def)
apply simp
apply safe
apply blast+
done 
(*>*)


lemma acc_le_prodI [intro!]:
  " acc rA; acc rB   acc(Product.le rA rB)"
(*<*)
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
(*>*)


lemma closed_lift2_sup:
  " closed (err A) (lift2 f); closed (err B) (lift2 g)   
  closed (err(A×B)) (lift2(sup f g))"
(*<*)
apply (unfold closed_def plussub_def lift2_def err_def' sup_def)
apply (simp split: err.split)
apply blast
done 
(*>*)

lemma unfold_plussub_lift2: "e1lift2 f e2 = lift2 f e1 e2"
(*<*) by (simp add: plussub_def) (*>*)


lemma plus_eq_Err_conv [simp]:
  assumes "xA"  "yA"  "semilat(err A, Err.le r, lift2 f)"
  shows "(x ⊔⇩f y = Err) = (¬(zA. x ⊑⇩r z  y ⊑⇩r z))"
(*<*)
proof -
  have plus_le_conv2:
    "r f z.  z  err A; semilat (err A, r, f); OK x  err A; OK y  err A;
                 OK x ⊔⇩f OK y ⊑⇩r z  OK x ⊑⇩r z  OK y ⊑⇩r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x ⊔⇩f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z: err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def' closed_def)
  apply simp
  done
qed
(*>*)

lemma err_semilat_Product_esl:
  "L1 L2.  err_semilat L1; err_semilat L2   err_semilat(Product.esl L1 L2)"
(*<*)
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done 
(*>*)

end

Theory Listn

(*  Title:      HOL/MicroJava/BV/Listn.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Lists of a fixed length.
*)

section ‹Fixed Length Lists›

theory Listn
imports Err
begin

definition list :: "nat  'a set  'a list set"
where
  "list n A = {xs. size xs = n  set xs  A}"

definition le :: "'a ord  ('a list)ord"
where
  "le r = list_all2 (λx y. x ⊑⇩r y)"

abbreviation
  lesublist :: "'a list  'a ord  'a list  bool"  ("(_ /[⊑⇘_⇙] _)" [50, 0, 51] 50) where
  "x [⊑r] y == x <=_(Listn.le r) y"

abbreviation
  lesssublist :: "'a list  'a ord  'a list  bool"  ("(_ /[⊏⇘_⇙] _)" [50, 0, 51] 50) where
  "x [⊏r] y == x <_(Listn.le r) y"

(*<*)
notation (ASCII)
  lesublist  ("(_ /[<=_] _)" [50, 0, 51] 50) and
  lesssublist  ("(_ /[<_] _)" [50, 0, 51] 50)

abbreviation (input)
  lesublist2 :: "'a list  'a ord  'a list  bool"  ("(_ /[⊑⇩_] _)" [50, 0, 51] 50) where
  "x [⊑⇩r] y == x [⊑r] y"

abbreviation (input)
  lesssublist2 :: "'a list  'a ord  'a list  bool"  ("(_ /[⊏⇩_] _)" [50, 0, 51] 50) where
  "x [⊏⇩r] y == x [⊏r] y"
(*>*)

abbreviation
  plussublist :: "'a list  ('a  'b  'c)  'b list  'c list"
    ("(_ /[⊔⇘_⇙] _)" [65, 0, 66] 65) where
  "x [⊔f] y == xmap2 f y"

(*<*)
notation (ASCII)
  plussublist  ("(_ /[+_] _)" [65, 0, 66] 65)

abbreviation (input)
  plussublist2 :: "'a list  ('a  'b  'c)  'b list  'c list"
    ("(_ /[⊔⇩_] _)" [65, 0, 66] 65) where
  "x [⊔⇩f] y == x [⊔f] y"
(*>*)


primrec coalesce :: "'a err list  'a list err"
where
  "coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"

definition sl :: "nat  'a sl  'a list sl"
where
  "sl n = (λ(A,r,f). (list n A, le r, map2 f))"

definition sup :: "('a  'b  'c err)  'a list  'b list  'c list err"
where
  "sup f = (λxs ys. if size xs = size ys then coalesce(xs [⊔f] ys) else Err)"

definition upto_esl :: "nat  'a esl  'a list esl"
where
  "upto_esl m = (λ(A,r,f). (Union{list n A |n. n  m}, le r, sup f))"


lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list: "xs [⊑r] ys = Listn.le r xs ys"
(*<*) by (simp add: lesub_def) (*>*)

lemma Nil_le_conv [iff]: "([] [⊑r] ys) = (ys = [])"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_notle_Nil [iff]: "¬ x#xs [⊑r] []"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_le_Cons [iff]: "x#xs [⊑r] y#ys = (x ⊑⇩r y  xs [⊑r] ys)"
(*<*)
by (simp add: lesub_def Listn.le_def)
(*>*)

lemma Cons_less_Conss [simp]:
  "order r   x#xs [⊏⇩r] y#ys = (x ⊏⇩r y  xs [⊑r] ys  x = y  xs [⊏⇩r] ys)"
(*<*)
apply (unfold lesssub_def)
apply blast
done
(*>*)

lemma list_update_le_cong:
  " i<size xs; xs [⊑r] ys; x ⊑⇩r y   xs[i:=x] [⊑r] ys[i:=y]"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
(*>*)


lemma le_listD: " xs [⊑r] ys; p < size xs   xs!p ⊑⇩r ys!p"
(*<*)
by (simp add: Listn.le_def lesub_def list_all2_nthD)
(*>*)

lemma le_list_refl: "x. x ⊑⇩r x  xs [⊑r] xs"
(*<*)
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
(*>*)

lemma le_list_trans: " order r; xs [⊑r] ys; ys [⊑r] zs   xs [⊑r] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_trans)
apply (erule order_trans)
apply assumption+
done
(*>*)

lemma le_list_antisym: " order r; xs [⊑r] ys; ys [⊑r] xs   xs = ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_antisym)
apply (rule order_antisym)
apply assumption+
done
(*>*)

lemma order_listI [simp, intro!]: "order r  order(Listn.le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
             dest: order_refl)
done
(*>*)

lemma lesub_list_impl_same_size [simp]: "xs [⊑r] ys  size ys = size xs"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
(*>*)

lemma lesssub_lengthD: "xs [⊏⇩r] ys  size ys = size xs"
(*<*)
apply (unfold lesssub_def)
apply auto
done
(*>*)

lemma le_list_appendI: "a [⊑r] b  c [⊑r] d  a@c [⊑r] b@d"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
(*>*)

lemma le_listI:
  assumes "length a = length b"
  assumes "n. n < length a  a!n ⊑⇩r b!n"
  shows "a [⊑r] b"
(*<*)
proof -
  from assms have "list_all2 r a b"
    by (simp add: list_all2_all_nthI lesub_def)
  then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
(*>*)

lemma listI: " size xs = n; set xs  A   xs  list n A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

(* FIXME: remove simp *)
lemma listE_length [simp]: "xs  list n A  size xs = n"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma less_lengthI: " xs  list n A; p < n   p < size xs"
(*<*) by simp (*>*)

lemma listE_set [simp]: "xs  list n A  set xs  A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma list_0 [simp]: "list 0 A = {[]}"
(*<*)
apply (unfold list_def)
apply auto
done
(*>*)

lemma in_list_Suc_iff:
  "(xs  list (Suc n) A) = (yA. ys  list n A. xs = y#ys)"
(*<*)
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done
(*>*)

lemma Cons_in_list_Suc [iff]:
  "(x#xs  list (Suc n) A) = (xA  xs  list n A)"
(*<*)
apply (simp add: in_list_Suc_iff)
done
(*>*)

lemma list_not_empty:
  "a. aA  xs. xs  list n A"
(*<*)
apply (induct "n")
 apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done
(*>*)


lemma nth_in [rule_format, simp]:
  "i n. size xs = n  set xs  A  i < n  (xs!i)  A"
(*<*)
apply (induct "xs")
 apply simp
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma listE_nth_in: " xs  list n A; i < n   xs!i  A"
(*<*) by auto (*>*)

lemma listn_Cons_Suc [elim!]:
  "l#xs  list n A  (n'. n = Suc n'  l  A  xs  list n' A  P)  P"
(*<*) by (cases n) auto (*>*)

lemma listn_appendE [elim!]:
  "a@b  list n A  (n1 n2. n=n1+n2  a  list n1 A  b  list n2 A  P)  P"
(*<*)
proof -
  have "n. a@b  list n A  n1 n2. n=n1+n2  a  list n1 A  b  list n2 A"
    (is "n. ?list a n  n1 n2. ?P a n n1 n2")
  proof (induct a)
    fix n assume "?list [] n"
    hence "?P [] n 0 n" by simp
    thus "n1 n2. ?P [] n n1 n2" by fast
  next
    fix n l ls
    assume "?list (l#ls) n"
    then obtain n' where n: "n = Suc n'" "l  A" and n': "ls@b  list n' A" by fastforce
    assume "n. ls @ b  list n A  n1 n2. n = n1 + n2  ls  list n1 A  b  list n2 A"
    from this and n' have "n1 n2. n' = n1 + n2  ls  list n1 A  b  list n2 A" .
    then obtain n1 n2 where "n' = n1 + n2" "ls  list n1 A" "b  list n2 A" by fast
    with n have "?P (l#ls) n (n1+1) n2" by simp
    thus "n1 n2. ?P (l#ls) n n1 n2" by fastforce
  qed
  moreover
  assume "a@b  list n A" "n1 n2. n=n1+n2  a  list n1 A  b  list n2 A  P"
  ultimately
  show ?thesis by blast
qed
(*>*)


lemma listt_update_in_list [simp, intro!]:
  " xs  list n A; xA   xs[i := x]  list n A"
(*<*)
apply (unfold list_def)
apply simp
done
(*>*)

lemma list_appendI [intro?]:
  " a  list n A; b  list m A   a @ b  list (n+m) A"
(*<*) by (unfold list_def) auto (*>*)

lemma list_map [simp]: "(map f xs  list (size xs) A) = (f ` set xs  A)"
(*<*) by (unfold list_def) simp (*>*)

lemma list_replicateI [intro]: "x  A  replicate n x  list n A"
(*<*) by (induct n) auto (*>*)

lemma plus_list_Nil [simp]: "[] [⊔f] xs = []"
(*<*)
apply (unfold plussub_def)
apply simp
done
(*>*)

lemma plus_list_Cons [simp]:
  "(x#xs) [⊔f] ys = (case ys of []  [] | y#ys  (x ⊔⇩f y)#(xs [⊔f] ys))"
(*<*) by (simp add: plussub_def split: list.split) (*>*)

lemma length_plus_list [rule_format, simp]:
  "ys. size(xs [⊔f] ys) = min(size xs) (size ys)"
(*<*)
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
(*>*)

lemma nth_plus_list [rule_format, simp]:
  "xs ys i. size xs = n  size ys = n  i<n  (xs [⊔f] ys)!i = (xs!i) ⊔⇩f (ys!i)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
(*>*)


lemma (in Semilat) plus_list_ub1 [rule_format]:
 " set xs  A; set ys  A; size xs = size ys 
   xs [⊑r] xs [⊔f] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_ub2:
 "set xs  A; set ys  A; size xs = size ys   ys [⊑r] xs [⊔f] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_lub [rule_format]:
shows "xs ys zs. set xs  A  set ys  A  set zs  A
   size xs = n  size ys = n 
  xs [⊑r] zs  ys [⊑r] zs  xs [⊔f] ys [⊑r] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) list_update_incr [rule_format]:
 "xA  set xs  A 
  (i. i<size xs  xs [⊑r] xs[i := x ⊔⇩f xs!i])"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma acc_le_listI [intro!]:
  " order r; acc r   acc(Listn.le r)"
(*<*)
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n  size ys = n  xs <_(Listn.le r) ys})")
 apply (erule wf_subset)
 apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "x xs. size xs = k  x#xs  M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. xs. size xs = k  a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs  maxA#ys  M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m  M")
apply (thin_tac "maxA#xs  M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply blast
done
(*>*)

lemma closed_listI:
  "closed S f  closed (list n S) (map2 f)"
(*<*)
apply (unfold closed_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done
(*>*)


lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
  apply (unfold Listn.sl_def)
  apply (simp (no_asm) only: semilat_Def split_conv)
  apply (rule conjI)
   apply simp
  apply (rule conjI)
   apply (simp only: closedI closed_listI)
  apply (simp (no_asm) only: list_def)
  apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
  done
qed
(*>*)

lemma Listn_sl: "semilat L  semilat (Listn.sl n L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all) (*>*)

lemma coalesce_in_err_list [rule_format]:
  "xes. xes  list n (err A)  coalesce xes  err(list n A)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
(*>*)

lemma lem: "x xs. x(#) xs = x#xs"
(*<*) by (simp add: plussub_def) (*>*)

lemma coalesce_eq_OK1_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  (zs. coalesce (xs [⊔f] ys) = OK zs  xs [⊑r] zs))"
(*<*)
apply (induct n)
  apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
(*>*)

lemma coalesce_eq_OK2_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  (zs. coalesce (xs [⊔f] ys) = OK zs  ys [⊑r] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
(*>*)

lemma lift2_le_ub:
  " semilat(err A, Err.le r, lift2 f); xA; yA; x ⊔⇩f y = OK z;
      uA; x ⊑⇩r u; y ⊑⇩r u   z ⊑⇩r u"
(*<*)
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
(*>*)

lemma coalesce_eq_OK_ub_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  (zs us. coalesce (xs [⊔f] ys) = OK zs  xs [⊑r] us  ys [⊑r] us
            us  list n A  zs [⊑r] us))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
 apply (blast intro: lift2_le_ub)
apply blast
done
(*>*)

lemma lift2_eq_ErrD:
  " x ⊔⇩f y = Err; semilat(err A, Err.le r, lift2 f); xA; yA 
   ¬(uA. x ⊑⇩r u  y ⊑⇩r u)"
(*<*) by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1]) (*>*)


lemma coalesce_eq_Err_D [rule_format]:
  " semilat(err A, Err.le r, lift2 f) 
   xs. xs  list n A  (ys. ys  list n A 
      coalesce (xs [⊔f] ys) = Err 
      ¬(zs  list n A. xs [⊑r] zs  ys [⊑r] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
 apply (blast dest: lift2_eq_ErrD)
done
(*>*)

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (xA. yA. x ⊔⇩f y  err A)"
(*<*)
apply (unfold closed_def)
apply (simp add: err_def')
done
(*>*)

lemma closed_map2_list [rule_format]:
  "closed (err A) (lift2 f) 
  xs. xs  list n A  (ys. ys  list n A 
  map2 f xs ys  list n (err A))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
(*>*)

lemma closed_lift2_sup:
  "closed (err A) (lift2 f) 
  closed (err (list n A)) (lift2 (sup f))"
(*<*) by (fastforce  simp add: closed_def plussub_def sup_def lift2_def
                          coalesce_in_err_list closed_map2_list
                split: err.split) (*>*)

lemma err_semilat_sup:
  "err_semilat (A,r,f) 
  err_semilat (list n A, Listn.le r, sup f)"
(*<*)
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
 apply (drule Semilat.orderI [OF Semilat.intro])
 apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
(*>*)

lemma err_semilat_upto_esl:
  "L. err_semilat L  err_semilat(upto_esl m L)"
(*<*)
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
                dest: lesub_list_impl_same_size
                simp add: plussub_def Listn.sup_def)
done
(*>*)

end

Theory Semilattices

(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Gerwin Klein
    Copyright   2003 TUM

Semilattices.
*)
(*<*)
theory Semilattices
imports Err Opt Product Listn
begin

end
(*>*)

Theory Typing_Framework

(*  Title:      HOL/MicroJava/BV/Typing_Framework.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section ‹Typing and Dataflow Analysis Framework›

theory Typing_Framework imports Semilattices begin

text ‹
  The relationship between dataflow analysis and a welltyped-instruction predicate. 
›
type_synonym
  's step_type = "nat  's  (nat × 's) list"

definition stable :: "'s ord  's step_type  's list  nat  bool"
where
  "stable r step τs p  ((q,τ)  set (step p (τs!p)). τ ⊑⇩r τs!q)"

definition stables :: "'s ord  's step_type  's list  bool"
where
  "stables r step τs  (p < size τs. stable r step τs p)"

definition wt_step :: "'s ord  's  's step_type  's list  bool"
where
  "wt_step r T step τs  (p<size τs. τs!p  T  stable r step τs p)"

definition is_bcv :: "'s ord  's  's step_type  nat  's set  ('s list  's list)  bool"
where
  "is_bcv r T step n A bcv  (τs0  list n A.
  (p<n. (bcv τs0)!p  T) = (τs  list n A. τs0 [⊑⇩r] τs  wt_step r T step τs))"

end

Theory SemilatAlg

(*  Title:      HOL/MicroJava/BV/SemilatAlg.thy
    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

section ‹More on Semilattices›

theory SemilatAlg
imports Typing_Framework
begin

definition lesubstep_type :: "(nat × 's) set  's ord  (nat × 's) set  bool"
    ("(_ /{⊑⇘_⇙} _)" [50, 0, 51] 50)
  where "A {⊑r} B  (p,τ)  A. τ'. (p,τ')  B  τ ⊑⇩r τ'"

notation (ASCII)
  lesubstep_type  ("(_ /{<='__} _)" [50, 0, 51] 50)

primrec pluslussub :: "'a list  ('a  'a  'a)  'a  'a"  ("(_ /⨆⇘_ _)" [65, 0, 66] 65)
where
  "pluslussub [] f y = y"
| "pluslussub (x#xs) f y = pluslussub xs f (x ⊔⇩f y)"
(*<*)
notation (ASCII)
  pluslussub  ("(_ /++'__ _)" [65, 1000, 66] 65)
(*>*)

definition bounded :: "'s step_type  nat  bool"
where
  "bounded step n  (p<n. τ. (q,τ')  set (step p τ). q<n)"

definition pres_type :: "'s step_type  nat  's set  bool"
where
  "pres_type step n A  (τA. p<n. (q,τ')  set (step p τ). τ'  A)"

definition mono :: "'s ord  's step_type  nat  's set  bool"
where
  "mono r step n A 
    (τ p τ'. τ  A  p<n  τ ⊑⇩r τ'  set (step p τ) {⊑r} set (step p τ'))"

lemma [iff]: "{} {⊑r} B" 
  (*<*) by (simp add: lesubstep_type_def) (*>*)

lemma [iff]: "(A {⊑r} {}) = (A = {})"
  (*<*) by (cases "A={}") (auto simp add: lesubstep_type_def) (*>*)

lemma lesubstep_union:
  " A1 {⊑r} B1; A2 {⊑r} B2   A1  A2 {⊑r} B1  B2"
  (*<*) by (auto simp add: lesubstep_type_def) (*>*)

lemma pres_typeD:
  " pres_type step n A; sA; p<n; (q,s')set (step p s)   s'  A"
(*<*) by (unfold pres_type_def, blast) (*>*)

lemma monoD:
  " mono r step n A; p < n; sA; s ⊑⇩r t   set (step p s) {⊑r} set (step p t)"
(*<*) by (unfold mono_def, blast) (*>*)

lemma boundedD: 
  " bounded step n; p < n; (q,t)  set (step p xs)   q < n" 
(*<*) by (unfold bounded_def, blast) (*>*)

lemma lesubstep_type_refl [simp, intro]:
  "(x. x ⊑⇩r x)  A {⊑r} A"
(*<*) by (unfold lesubstep_type_def) auto (*>*)

lemma lesub_step_typeD:
  "A {⊑r} B  (x,y)  A  y'. (x, y')  B  y ⊑⇩r y'"
(*<*) by (unfold lesubstep_type_def) blast (*>*)


lemma list_update_le_listI [rule_format]:
  "set xs  A  set ys  A  xs [⊑⇩r] ys  p < size xs   
   x ⊑⇩r ys!p  semilat(A,r,f)  xA  
   xs[p := x ⊔⇩f xs!p] [⊑⇩r] ys"
(*<*)
  apply (simp only: Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done
(*>*)

lemma plusplus_closed: assumes "Semilat A r f" shows
  "y.  set x  A; y  A  xf y  A"
(*<*)
proof (induct x)
  interpret Semilat A r f by fact
  show "y. y  A  []f y  A" by simp
  fix y x xs
  assume y: "y  A" and xxs: "set (x#xs)  A"
  assume IH: "y.  set xs  A; y  A  xsf y  A"
  from xxs obtain x: "x  A" and xs: "set xs  A" by simp
  from x y have "xf y  A" ..
  with xs have "xsf (xf y)  A" by (rule IH)
  thus "x#xsf y  A" by simp
qed
(*>*)

lemma (in Semilat) pp_ub2:
 "y.  set x  A; y  A  yr xf y"
(*<*)
proof (induct x)
  from semilat show "y. yr []f y" by simp
  
  fix y a l assume y:  "y  A" and "set (a#l)  A"
  then obtain a: "a  A" and x: "set l  A" by simp
  assume "y. set l  A; y  A  yr lf y"
  from this and x have IH: "y. y  A  yr lf y" .

  from a y have "yr af y" ..
  also from a y have "af y  A" ..
  hence "(af y)r lf (af y)" by (rule IH)
  finally have "yr lf (af y)" .
  thus "yr (a#l)f y" by simp
qed
(*>*)


lemma (in Semilat) pp_ub1:
shows "y. set ls  A; y  A; x  set ls  xr lsf y"
(*<*)
proof (induct ls)
  show "y. x  set []  xr []f y" by simp

  fix y s ls
  assume "set (s#ls)  A"
  then obtain s: "s  A" and ls: "set ls  A" by simp
  assume y: "y  A" 

  assume "y. set ls  A; y  A; x  set ls  xr lsf y"
  from this and ls have IH: "y. x  set ls  y  A  xr lsf y" .

  assume "x  set (s#ls)"
  then obtain xls: "x = s  x  set ls" by simp
  moreover {
    assume xs: "x = s"
    from s y have "sr sf y" ..
    also from s y have "sf y  A" ..
    with ls have "(sf y)r lsf (sf y)" by (rule pp_ub2)
    finally have "sr lsf (sf y)" .
    with xs have "xr lsf (sf y)" by simp
  } 
  moreover {
    assume "x  set ls"
    hence "y. y  A  xr lsf y" by (rule IH)
    moreover from s y have "sf y  A" ..
    ultimately have "xr lsf (sf y)" .
  }
  ultimately 
  have "xr lsf (sf y)" by blast
  thus "xr (s#ls)f y" by simp
qed
(*>*)


lemma (in Semilat) pp_lub:
  assumes z: "z  A"
  shows 
  "y. y  A  set xs  A  x  set xs. xr z  yr z  xsf yr z"
(*<*)
proof (induct xs)
  fix y assume "yr z" thus "[]f yr z" by simp
next
  fix y l ls assume y: "y  A" and "set (l#ls)  A"
  then obtain l: "l  A" and ls: "set ls  A" by auto
  assume "x  set (l#ls). xr z"
  then obtain lz: "lr z" and lsz: "x  set ls. xr z" by auto
  assume "yr z" with lz have "lf yr z" using l y z ..
  moreover
  from l y have "lf y  A" ..
  moreover
  assume "y. y  A  set ls  A  x  set ls. xr z  yr z
           lsf yr z"
  ultimately
  have "lsf (lf y)r z" using ls lsz by -
  thus "(l#ls)f yr z" by simp
qed
(*>*)


lemma ub1': assumes "Semilat A r f"
shows "(p,s)  set S. s  A; y  A; (a,b)  set S 
   br map snd [(p', t')  S. p' = a]f y" 
(*<*)
proof -
  interpret Semilat A r f by fact
  let "br ?mapf y" = ?thesis

  assume "y  A"
  moreover
  assume "(p,s)  set S. s  A"
  hence "set ?map  A" by auto
  moreover
  assume "(a,b)  set S"
  hence "b  set ?map" by (induct S, auto)
  ultimately
  show ?thesis by - (rule pp_ub1)
qed
(*>*)
    
 
lemma plusplus_empty:  
  "s'. (q, s')  set S  s'f ss ! q = ss ! q 
   (map snd [(p', t')  S. p' = q]f ss ! q) = ss ! q"
(*<*)
apply (induct S)
apply auto 
done
(*>*)


end

Theory Typing_Framework_err

(*  Title:      HOL/MicroJava/BV/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

section ‹Lifting the Typing Framework to err, app, and eff›

theory Typing_Framework_err imports Typing_Framework SemilatAlg begin

definition wt_err_step :: "'s ord  's err step_type  's err list  bool"
where
  "wt_err_step r step τs  wt_step (Err.le r) Err step τs"

definition wt_app_eff :: "'s ord  (nat  's  bool)  's step_type  's list  bool"
where
  "wt_app_eff r app step τs 
    (p < size τs. app p (τs!p)  ((q,τ)  set (step p (τs!p)). τ <=_r τs!q))"

definition map_snd :: "('b  'c)  ('a × 'b) list  ('a × 'c) list"
where
  "map_snd f = map (λ(x,y). (x, f y))"

definition error :: "nat  (nat × 'a err) list"
where
  "error n = map (λx. (x,Err)) [0..<n]"

definition err_step :: "nat  (nat  's  bool)  's step_type  's err step_type"
where
  "err_step n app step p t = 
  (case t of 
    Err    error n
  | OK τ  if app p τ then map_snd OK (step p τ) else error n)"

definition app_mono :: "'s ord  (nat  's  bool)  nat  's set  bool"
where
  "app_mono r app n A 
    (s p t. s  A  p < n  s ⊑⇩r t  app p t  app p s)"


lemmas err_step_defs = err_step_def map_snd_def error_def


lemma bounded_err_stepD:
  " bounded (err_step n app step) n;
     p < n; app p a; (q,b)  set (step p a)   q < n"
(*<*)
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done
(*>*)


lemma in_map_sndD: "(a,b)  set (map_snd f xs)  b'. (a,b')  set xs"
(*<*)
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done
(*>*)


lemma bounded_err_stepI:
  "p. p < n  (s. ap p s  ((q,s')  set (step p s). q < n))
   bounded (err_step n ap step) n"
(*<*)
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
(*>*)


lemma bounded_lift:
  "bounded step n  bounded (err_step n app step) n"
(*<*)
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac τ)
  apply (auto simp add: map_snd_def split: if_split_asm)
  done
(*>*)


lemma le_list_map_OK [simp]:
  "b. (map OK a [⊑Err.le r] map OK b) = (a [⊑⇩r] b)"
(*<*)
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done
(*>*)


lemma map_snd_lessI:
  "set xs {⊑r} set ys  set (map_snd OK xs) {⊑Err.le r} set (map_snd OK ys)"
(*<*)
  apply (induct xs)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done
(*>*)


lemma mono_lift:
  " order r; app_mono r app n A; bounded (err_step n app step) n;
    s p t. s  A  p < n  s ⊑⇩r t  app p t  set (step p s) {⊑r} set (step p t) 
    mono (Err.le r) (err_step n app step) n (err A)"
(*<*)
apply (simp only: app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac τ)
 apply simp 
apply simp
apply (case_tac τ')
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
(*>*)
 
lemma in_errorD: "(x,y)  set (error n)  y = Err"
(*<*) by (auto simp add: error_def) (*>*)

lemma pres_type_lift:
  "sA. p. p < n  app p s  ((q, s')set (step p s). s'  A) 
   pres_type (err_step n app step) n (err A)"  
(*<*)
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac τ)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: if_split_asm)
 apply fast
apply (drule in_errorD)
apply simp
done
(*>*)


lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
(*<*)
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err)  set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "p. p < size ts  ts ! p  Err" 
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "(q,t)  set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def) 
         (auto iff: not_Err_eq)
    assume "¬ app p (map ok_val ts ! p)"
    with OKp lp have "¬ app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)" 
      by (simp add: err_step_def)    
    with err ts obtain q where 
      "(q,Err)  set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto    
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q  Err" ..
    ultimately show False by blast
  qed
  
  show "(q,t)set(step p (map ok_val ts ! p)). t ⊑⇩r map ok_val ts ! q" 
  proof clarify
    fix q t assume q: "(q,t)  set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "(q,t)  set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def) 
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q  Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t ⊑⇩r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def) 
  qed
qed
(*>*)


lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
(*<*)
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)" 
  hence p: "p < size ts" by simp
  thus "map OK ts ! p  Err" by simp
  { fix q t
    assume q: "(q,t)  set (err_step (size ts) app step p (map OK ts ! p))" 
    with p app_eff obtain 
      "app p (ts ! p)" "(q,t)  set (step p (ts!p)). t ⊑⇩r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately     
    have "tErr.le r map OK ts ! q" 
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed
(*>*)

end

Theory Kildall

(*  Title:      HOL/MicroJava/BV/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM

Kildall's algorithm.
*)

section ‹Kildall's Algorithm \label{sec:Kildall}›

theory Kildall
imports SemilatAlg
begin



primrec propa :: "'s binop  (nat × 's) list  's list  nat set  's list * nat set"
where
  "propa f []      τs w = (τs,w)"
| "propa f (q'#qs) τs w = (let (q,τ) = q';
                             u = τf τs!q;
                             w' = (if u = τs!q then w else insert q w)
                         in propa f qs (τs[q := u]) w')"

definition iter :: "'s binop  's step_type 
          's list  nat set  's list × nat set"
where
  "iter f step τs w =
   while (λ(τs,w). w  {})
         (λ(τs,w). let p = SOME p. p  w
                   in propa f (step p (τs!p)) τs (w-{p}))
         (τs,w)"

definition unstables :: "'s ord  's step_type  's list  nat set"
where
  "unstables r step τs = {p. p < size τs  ¬stable r step τs p}"

definition kildall :: "'s ord  's binop  's step_type  's list  's list"
where
  "kildall r f step τs = fst(iter f step τs (unstables r step τs))"

primrec merges :: "'s binop  (nat × 's) list  's list  's list"
where
  "merges f []      τs = τs"
| "merges f (p'#ps) τs = (let (p,τ) = p' in merges f ps (τs[p := τf τs!p]))"


lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]


lemma (in Semilat) nth_merges:
 "ss. p < length ss; ss  list n A; (p,t)set ps. p<n  tA  
  (merges f ps ss)!p = map snd [(p',t')  ps. p'=p]f ss!p"
  (is "ss. _; _; ?steptype ps  ?P ss ps")
(*<*)
proof (induct ps)
  show "ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss  list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "bA" and ps': "?steptype ps'"
    by (cases p') auto
  assume "ss. p< length ss  ss  list n A  ?steptype ps'  ?P ss ps'"
  hence IH: "ss. ss  list n A  p < length ss  ?P ss ps'" using ps' by iprover

  from ss ab
  have "ss[a := bf ss!a]  list n A" by (simp add: closedD)
  moreover
  with l have "p < length (ss[a := bf ss!a])" by simp
  ultimately
  have "?P (ss[a := bf ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed
(*>*)


(** merges **)

lemma length_merges [simp]:
  "ss. size(merges f ps ss) = size ss"
(*<*) by (induct ps, auto) (*>*)

lemma (in Semilat) merges_preserves_type_lemma:
shows "xs. xs  list n A  ((p,x)  set ps. p<n  xA)
          merges f ps xs  list n A"
(*<*)
apply (insert closedI)
apply (unfold closed_def)
apply (induct ps)
 apply simp
apply clarsimp
done
(*>*)

lemma (in Semilat) merges_preserves_type [simp]:
 " xs  list n A; (p,x)  set ps. p<n  xA 
   merges f ps xs  list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "xs. xs  list n A  ((p,x)set ps. p<size xs  x  A)  xs [⊑r] merges f ps xs"
(*<*)
apply (induct ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
(*>*)

lemma (in Semilat) merges_incr:
 " xs  list n A; (p,x)set ps. p<size xs  x  A  
   xs [⊑r] merges f ps xs"
  by (simp add: merges_incr_lemma)


lemma (in Semilat) merges_same_conv [rule_format]:
 "(xs. xs  list n A  ((p,x)set ps. p<size xs  xA)  
     (merges f ps xs = xs) = ((p,x)set ps. xr xs!p))"
(*<*)
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := xf xs!p] [⊑r] xs")
     apply (force dest!: le_listD simp add: nth_list_update)
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify 
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done
(*>*)


lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs  A  set ys  A  xs [⊑r] ys  p < size xs   
   xr ys!p  xA  xs[p := xf xs!p] [⊑r] ys"
(*<*)
  apply (insert semilat)
  apply (simp only: Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done
(*>*)

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts  A"  "set ss  A"
    "(p,t)set ps. tr ts!p  t  A  p < size ts"  "ss [⊑r] ts"
  shows "merges f ps ss [⊑r] ts"
(*<*)
proof -
  { fix t ts ps
    have
    "qs. set ts  A; (p,t)set ps. tr ts!p  t  A  p< size ts  
    set qs  set ps   
    (ss. set ss  A  ss [⊑r] ts  merges f qs ss [⊑r] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done 
  } note this [dest]  
  from assms show ?thesis by blast
qed
(*>*)


(** propa **)

lemma decomp_propa:
  "ss w. ((q,t)set qs. q < size ss)  
   propa f qs ss w = 
   (merges f qs ss, {q. t.(q,t)set qs  tf ss!q  ss!q}  w)"
(*<*)
  apply (induct qs)
   apply simp   
  apply (simp (no_asm))
  apply clarify  
  apply simp
  apply (rule conjI) 
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done 
(*>*)

(** iter **)

lemma (in Semilat) stable_pres_lemma:
shows "pres_type step n A; bounded step n; 
     ss  list n A; p  w; qw. q < n; 
     q. q < n  q  w  stable r step ss q; q < n; 
     s'. (q,s')  set (step p (ss!p))  s'f ss!q = ss!q; 
     q  w  q = p  
   stable r step (merges f (step p (ss!p)) ss) q"
(*<*)
  apply (unfold stable_def)
  apply (subgoal_tac "s'. (q,s')  set (step p (ss!p))  s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "λx. (a, b)  set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q  w")
  apply simp
  apply (rule ub1')
     apply (rule Semilat.intro)
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done
(*>*)


lemma (in Semilat) merges_bounded_lemma:
 " mono r step n A; bounded step n; 
    (p',s')  set (step p (ss!p)). s'  A; ss  list n A; ts  list n A; p < n; 
    ss [⊑⇩r] ts; p. p < n  stable r step ts p  
   merges f (step p (ss!p)) ss [⊑⇩r] ts" 
(*<*)
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)
  
  apply (drule lesub_step_typeD, assumption) 
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done
(*>*)

lemma termination_lemma: assumes "Semilat A r f"
shows " ss  list n A; (q,t)set qs. q<n  tA; pw   
      ss [⊏⇩r] merges f qs ss  
  merges f qs ss = ss  {q. t. (q,t)set qs  tf ss!q  ss!q}  (w-{p})  w"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format]) 
    apply assumption+
      defer
      apply (rule sym, assumption)
     defer apply simp
     apply (subgoal_tac "q t. ¬((q, t)  set qs  tf ss ! q  ss ! q)")
     apply (blast intro!: psubsetI elim: equalityE)
     apply clarsimp
     apply (drule bspec, assumption) 
     apply (drule bspec, assumption)
     apply clarsimp
    done 
qed
(*>*)

lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows " acc r; pres_type step n A; mono r step n A;
     bounded step n; pw0. p < n; ss0  list n A;
     p<n. p  w0  stable r step ss0 p  
   iter f step ss0 w0 = (ss',w')
   
   ss'  list n A  stables r step ss'  ss0 [⊑⇩r] ss' 
   (tslist n A. ss0 [⊑⇩r] ts  stables r step ts  ss' [⊑⇩r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
  apply (unfold iter_def stables_def)
  apply (rule_tac P = "λ(ss,w).
   ss  list n A  (p<n. p  w  stable r step ss p)  ss0 [⊑⇩r] ss 
   (tslist n A. ss0 [⊑⇩r] ts  stables r step ts  ss [⊑⇩r] ts) 
   (pw. p < n)" and
   r = "{(ss',ss) . ss [⊏⇩r] ss'} <*lex*> finite_psubset"
         in while_rule)

  ― ‹Invariant holds initially:›
  apply (simp add:stables_def)

  ― ‹Invariant is preserved:›
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "(SOME p. p  w)  w")
   prefer 2 apply (fast intro: someI)
  apply(subgoal_tac "(q,t)  set (step (SOME p. p  w) (ss ! (SOME p. p  w))). q < length ss  t  A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (subst decomp_propa)
   apply blast
  apply simp
  apply (rule conjI)
   apply (rule merges_preserves_type)
   apply blast
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (rule conjI)
   apply clarify
   apply (blast intro!: stable_pres_lemma)
  apply (rule conjI)
   apply (blast intro!: merges_incr intro: le_list_trans)
  apply (rule conjI)
   apply clarsimp
   apply (blast intro!: merges_bounded_lemma)
  apply (blast dest!: boundedD)


  ― ‹Postcondition holds upon termination:›
  apply(clarsimp simp add: stables_def split_paired_all)

  ― ‹Well-foundedness of the termination relation:›
  apply (rule wf_lex_prod)
   apply (insert orderI [THEN acc_le_listI])
   apply (simp only: acc_def lesssub_def)
  apply (rule wf_finite_psubset) 

  ― ‹Loop decreases along termination relation:›
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "(SOME p. p  w)  w")
   prefer 2 apply (fast intro: someI)
  apply(subgoal_tac "(q,t)  set (step (SOME p. p  w) (ss ! (SOME p. p  w))). q < length ss  t  A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (subst decomp_propa)
   apply blast
  apply clarify
  apply (simp del: listE_length
      add: lex_prod_def finite_psubset_def 
           bounded_nat_set_is_finite)
  apply (rule termination_lemma)
  apply (rule assms)
  apply assumption+
  defer
  apply assumption
  apply clarsimp
  done
qed
(*>*)


lemma kildall_properties: assumes "Semilat A r f"
shows " acc r; pres_type step n A; mono r step n A;
     bounded step n; ss0  list n A  
  kildall r f step ss0  list n A 
  stables r step (kildall r f step ss0) 
  ss0 [⊑⇩r] kildall r f step ss0 
  (tslist n A. ss0 [⊑⇩r] ts  stables r step ts 
                 kildall r f step ss0 [⊑⇩r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply (unfold kildall_def)
  apply(case_tac "iter f step ss0 (unstables r step ss0)")
  apply(simp)
  apply (rule iter_properties)
  apply (simp_all add: unstables_def stable_def)
  apply (rule Semilat.intro)
  apply (rule semilat)
  done
qed


lemma is_bcv_kildall: assumes "Semilat A r f"
shows " acc r; top r T; pres_type step n A; bounded step n; mono r step n A 
   is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(unfold is_bcv_def wt_step_def)
  apply(insert ‹Semilat A r f semilat kildall_properties[of A])
  apply(simp add:stables_def)
  apply clarify
  apply(subgoal_tac "kildall r f step τs0  list n A")
   prefer 2 apply (simp(no_asm_simp))
  apply (rule iffI)
   apply (rule_tac x = "kildall r f step τs0" in bexI) 
    apply (rule conjI)
     apply (blast)
    apply (simp  (no_asm_simp))
   apply(assumption)
  apply clarify
  apply(subgoal_tac "kildall r f step τs0!p <=_r τs!p")
   apply simp
  apply (blast intro!: le_listD less_lengthI)
  done
qed
(*>*)

end

Theory LBVSpec

(*  Title:      HOL/MicroJava/BV/LBVSpec.thy
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹The Lightweight Bytecode Verifier›

theory LBVSpec
imports SemilatAlg Opt
begin

type_synonym
  's certificate = "'s list"   

primrec merge :: "'s certificate  's binop  's ord  's  nat  (nat × 's) list  's  's"
where
  "merge cert f r T pc []     x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in 
                                  if pc'=pc+1 then s' ⊔⇩f x
                                  else if s' ⊑⇩r cert!pc' then x
                                  else T)"

definition wtl_inst :: "'s certificate  's binop  's ord  's 
              's step_type  nat  's  's"
where
  "wtl_inst cert f r T step pc s = merge cert f r T pc (step pc s) (cert!(pc+1))"

definition wtl_cert :: "'s certificate  's binop  's ord  's  's 
              's step_type  nat  's  's"
where
  "wtl_cert cert f r T B step pc s =
  (if cert!pc = B then 
    wtl_inst cert f r T step pc s
  else
    if s ⊑⇩r cert!pc then wtl_inst cert f r T step pc (cert!pc) else T)"

primrec wtl_inst_list :: "'a list  's certificate  's binop  's ord  's  's 
                    's step_type  nat  's  's"
where
  "wtl_inst_list []     cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s = 
    (let s' = wtl_cert cert f r T B step pc s in
      if s' = T  s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"

definition cert_ok :: "'s certificate  nat  's  's  's set  bool"
where
  "cert_ok cert n T B A  (i < n. cert!i  A  cert!i  T)  (cert!n = B)"

definition bottom :: "'a ord  'a  bool"
where
  "bottom r B  (x. B ⊑⇩r x)"


locale lbv = Semilat +
  fixes T :: "'a" ("") 
  fixes B :: "'a" ("") 
  fixes step :: "'a step_type" 
  assumes top: "top r "
  assumes T_A: "  A"
  assumes bot: "bottom r " 
  assumes B_A: "  A"

  fixes merge :: "'a certificate  nat  (nat × 'a) list  'a  'a"
  defines mrg_def: "merge cert  LBVSpec.merge cert f r "

  fixes wti :: "'a certificate  nat  'a  'a"
  defines wti_def: "wti cert  wtl_inst cert f r  step"
 
  fixes wtc :: "'a certificate  nat  'a  'a"
  defines wtc_def: "wtc cert  wtl_cert cert f r   step"

  fixes wtl :: "'b list  'a certificate  nat  'a  'a"
  defines wtl_def: "wtl ins cert  wtl_inst_list ins cert f r   step"


lemma (in lbv) wti:
  "wti c pc s = merge c pc (step pc s) (c!(pc+1))"
  (*<*) by (simp add: wti_def mrg_def wtl_inst_def) (*>*)

lemma (in lbv) wtc: 
  "wtc c pc s = (if c!pc =  then wti c pc s else if s ⊑⇩r c!pc then wti c pc (c!pc) else )"
  (*<*) by (unfold wtc_def wti_def wtl_cert_def) rule (*>*)

lemma cert_okD1 [intro?]:
  "cert_ok c n T B A  pc < n  c!pc  A"
  (*<*) by (unfold cert_ok_def) fast (*>*)

lemma cert_okD2 [intro?]:
  "cert_ok c n T B A  c!n = B"
  (*<*) by (simp add: cert_ok_def) (*>*)

lemma cert_okD3 [intro?]:
  "cert_ok c n T B A  B  A  pc < n  c!Suc pc  A"
  (*<*) by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2) (*>*)

lemma cert_okD4 [intro?]:
  "cert_ok c n T B A  pc < n  c!pc  T"
  (*<*) by (simp add: cert_ok_def) (*>*)

declare Let_def [simp]

subsection "more semilattice lemmas"


lemma (in lbv) sup_top [simp, elim]:
  assumes x: "x  A" 
  shows "x ⊔⇩f  = "
(*<*)
proof -
  from top have "x ⊔⇩f  ⊑⇩r " ..
  moreover from x T_A have " ⊑⇩r x ⊔⇩f " ..
  ultimately show ?thesis ..
qed
(*>*)
  
lemma (in lbv) plusplussup_top [simp, elim]:
  "set xs  A  xsf  = "
  by (induct xs) auto


lemma (in Semilat) pp_ub1':
  assumes S: "snd`set S  A" 
  assumes y: "y  A" and ab: "(a, b)  set S" 
  shows "b ⊑⇩r map snd [(p', t')  S . p' = a]f y"
(*<*)
proof -
  from S have "(x,y)  set S. y  A" by auto
  with Semilat_axioms show ?thesis using y ab by (rule ub1')
qed 
(*>*)

lemma (in lbv) bottom_le [simp, intro!]: " ⊑⇩r x"
  by (insert bot) (simp add: bottom_def)

lemma (in lbv) le_bottom [simp]: "x ⊑⇩r  = (x = )"
  by (blast intro: antisym_r)


subsection "merge"

lemma (in lbv) merge_Nil [simp]:
  "merge c pc [] x = x" by (simp add: mrg_def)

lemma (in lbv) merge_Cons [simp]:
  "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
                                        else if snd l ⊑⇩r c!fst l then x
                                        else )"
  by (simp add: mrg_def split_beta)

lemma (in lbv) merge_Err [simp]:
  "snd`set ss  A  merge c pc ss  = "
  by (induct ss) auto

lemma (in lbv) merge_not_top:
  "x. snd`set ss  A  merge c pc ss x    
  (pc',s')  set ss. (pc'  pc+1  s' ⊑⇩r c!pc')"
  (is "x. ?set ss  ?merge ss x  ?P ss")
(*<*)
proof (induct ss)
  show "?P []" by simp
next
  fix x ls l
  assume "?set (l#ls)" then obtain set: "snd`set ls  A" by simp
  assume merge: "?merge (l#ls) x" 
  moreover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  ultimately
  obtain x' where merge': "?merge ls x'" by simp 
  assume "x. ?set ls  ?merge ls x  ?P ls" hence "?P ls" using set merge' .
  moreover
  from merge set
  have "pc'  pc+1  s' ⊑⇩r c!pc'" by (simp split: if_split_asm)
  ultimately show "?P (l#ls)" by simp
qed
(*>*)


lemma (in lbv) merge_def:
  shows 
  "x. x  A  snd`set ss  A 
  merge c pc ss x = 
  (if (pc',s')  set ss. pc'pc+1  s' ⊑⇩r c!pc' then
    map snd [(p',t')  ss. p'=pc+1]f x
  else )" 
  (is "x. _  _  ?merge ss x = ?if ss x" is "x. _  _  ?P ss x")
(*<*)
proof (induct ss)
  fix x show "?P [] x" by simp
next 
  fix x assume x: "x  A" 
  fix l::"nat × 'a" and ls  
  assume "snd`set (l#ls)  A"
  then obtain l: "snd l  A" and ls: "snd`set ls  A" by auto
  assume "x. x  A  snd`set ls  A  ?P ls x" 
  hence IH: "x. x  A  ?P ls x" using ls by iprover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  hence "?merge (l#ls) x = ?merge ls 
    (if pc'=pc+1 then s' ⊔⇩f x else if s' ⊑⇩r c!pc' then x else )"
    (is "?merge (l#ls) x = ?merge ls ?if'")
    by simp 
  also have " = ?if ls ?if'" 
  proof -
    from l have "s'  A" by simp
    with x have "s' ⊔⇩f x  A" by simp
    with x T_A have "?if'  A" by auto
    hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
  qed
  also have " = ?if (l#ls) x"
    proof (cases "(pc', s')set (l#ls). pc'pc+1  s' ⊑⇩r c!pc'")
      case True
      hence "(pc', s')set ls. pc'pc+1  s' ⊑⇩r c!pc'" by auto
      moreover
      from True have 
        "map snd [(p',t')  ls . p'=pc+1]f ?if' = 
        (map snd [(p',t')  l#ls . p'=pc+1]f x)"
        by simp
      ultimately
      show ?thesis using True by simp
    next
      case False 
      moreover
      from ls have "set (map snd [(p', t')  ls . p' = Suc pc])  A" by auto
      ultimately show ?thesis by auto
    qed
  finally show "?P (l#ls) x" .
qed
(*>*)

lemma (in lbv) merge_not_top_s:
  assumes x:  "x  A" and ss: "snd`set ss  A"
  assumes m:  "merge c pc ss x  "
  shows "merge c pc ss x = (map snd [(p',t')  ss. p'=pc+1]f x)"
(*<*)
proof -
  from ss m have "(pc',s')  set ss. (pc'  pc+1  s' <=_r c!pc')" 
    by (rule merge_not_top)
  with x ss m show ?thesis by - (drule merge_def, auto split: if_split_asm)
qed
(*>*)

subsection "wtl-inst-list"

lemmas [iff] = not_Err_eq

lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s" 
  by (simp add: wtl_def)

lemma (in lbv) wtl_Cons [simp]: 
  "wtl (i#is) c pc s = 
  (let s' = wtc c pc s in if s' =   s =  then  else wtl is c (pc+1) s')"
  by (simp add: wtl_def wtc_def)

lemma (in lbv) wtl_Cons_not_top:
  "wtl (i#is) c pc s   = 
  (wtc c pc s    s  T  wtl is c (pc+1) (wtc c pc s)  )"
  by (auto simp del: split_paired_Ex)

lemma (in lbv) wtl_top [simp]:  "wtl ls c pc  = "
  by (cases ls) auto

lemma (in lbv) wtl_not_top:
  "wtl ls c pc s    s  "
  by (cases "s=") auto

lemma (in lbv) wtl_append [simp]:
  "pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
  by (induct a) auto

lemma (in lbv) wtl_take:
  "wtl is c pc s    wtl (take pc' is) c pc s  "
  (is "?wtl is  _  _")
(*<*)
proof -
  assume "?wtl is  "
  hence "?wtl (take pc' is @ drop pc' is)  " by simp  
  thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed
(*>*)

lemma take_Suc:
  "n. n < length l  take (Suc n) l = (take n l)@[l!n]" (is "?P l")
(*<*)
proof (induct l)
  show "?P []" by simp
next
  fix x xs assume IH: "?P xs"  
  show "?P (x#xs)"
  proof (intro strip)
    fix n assume "n < length (x#xs)"
    with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]" 
      by (cases n, auto)
  qed
qed
(*>*)

lemma (in lbv) wtl_Suc:
  assumes suc: "pc+1 < length is"
  assumes wtl: "wtl (take pc is) c 0 s  "
  shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
(*<*)
proof -
  from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
  with suc wtl show ?thesis by (simp add: min_def)
qed
(*>*)

lemma (in lbv) wtl_all:
  assumes all: "wtl is c 0 s  " (is "?wtl is  _") 
  assumes pc:  "pc < length is"
  shows  "wtc c pc (wtl (take pc is) c 0 s)  "
(*<*)
proof -
  from pc have "0 < length (drop pc is)" by simp
  then  obtain i r where Cons: "drop pc is = i#r" 
    by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
  hence "i#r = drop pc is" ..
  with all have take: "?wtl (take pc is@i#r)  " by simp 
  from pc have "is!pc = drop pc is ! 0" by simp
  with Cons have "is!pc = i" by simp
  with take pc show ?thesis by (auto simp add: min_def split: if_split_asm)
qed
(*>*)

subsection "preserves-type"

lemma (in lbv) merge_pres:
  assumes s0: "snd`set ss  A" and x: "x  A"
  shows "merge c pc ss x  A"
(*<*)
proof -
  from s0 have "set (map snd [(p', t')  ss . p'=pc+1])  A" by auto
  with x semilat Semilat_axioms  have "(map snd [(p', t')  ss . p'=pc+1]f x)  A"
    by (auto intro!: plusplus_closed)
  with s0 x show ?thesis by (simp add: merge_def T_A)
qed
(*>*)
  
lemma pres_typeD2:
  "pres_type step n A  s  A  p < n  snd`set (step p s)  A"
  by auto (drule pres_typeD)

lemma (in lbv) wti_pres [intro?]:
  assumes pres: "pres_type step n A" 
  assumes cert: "c!(pc+1)  A"
  assumes s_pc: "s  A" "pc < n"
  shows "wti c pc s  A"
(*<*)
proof -
  from pres s_pc have "snd`set (step pc s)  A" by (rule pres_typeD2)
  with cert show ?thesis by (simp add: wti merge_pres)
qed
(*>*)

lemma (in lbv) wtc_pres:
  assumes "pres_type step n A"
  assumes "c!pc  A" and "c!(pc+1)  A"
  assumes "s  A" and "pc < n"
  shows "wtc c pc s  A"
(*<*)
proof -
  have "wti c pc s  A" using assms(1,3-5) ..
  moreover have "wti c pc (c!pc)  A" using assms(1,3,2,5) ..
  ultimately show ?thesis using T_A by (simp add: wtc) 
qed
(*>*)

lemma (in lbv) wtl_pres:
  assumes pres: "pres_type step (length is) A"
  assumes cert: "cert_ok c (length is)   A"
  assumes s:    "s  A" 
  assumes all:  "wtl is c 0 s  "
  shows "pc < length is  wtl (take pc is) c 0 s  A"
  (is "?len pc  ?wtl pc  A")
(*<*)
proof (induct pc)
  from s show "?wtl 0  A" by simp
next
  fix n assume Suc_n: "Suc n < length is"
  hence n1: "n+1 < length is" by simp
  then obtain n: "n < length is" by simp
  assume "n < length is  ?wtl n  A"
  hence "?wtl n  A" using n .
  from pres _ _ this n
  have "wtc c n (?wtl n)  A"
  proof (rule wtc_pres)
    from cert n show "c!n  A" by (rule cert_okD1)
    from cert n1 show "c!(n+1)  A" by (rule cert_okD1)
  qed
  also
  from all n have "?wtl n  " by - (rule wtl_take)
  with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
  finally  show "?wtl (Suc n)  A" by simp
qed
(*>*)

end

Theory LBVCorrect

(*
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹Correctness of the LBV›

theory LBVCorrect
imports LBVSpec Typing_Framework
begin

locale lbvs = lbv +
  fixes s0  :: 'a
  fixes c   :: "'a list"
  fixes ins :: "'b list"
  fixes τs  :: "'a list"
  defines phi_def:
  "τs  map (λpc. if c!pc =  then wtl (take pc ins) c 0 s0 else c!pc) 
       [0..<size ins]"

  assumes bounded: "bounded step (size ins)"
  assumes cert: "cert_ok c (size ins)   A"
  assumes pres: "pres_type step (size ins) A"

lemma (in lbvs) phi_None [intro?]:
  " pc < size ins; c!pc =    τs!pc = wtl (take pc ins) c 0 s0"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_Some [intro?]:
  " pc < size ins; c!pc     τs!pc = c!pc"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_len [simp]: "size τs = size ins"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) wtl_suc_pc:
  assumes all: "wtl ins c 0 s0  " 
  assumes pc:  "pc+1 < size ins"
  shows "wtl (take (pc+1) ins) c 0 s0 ⊑⇩r τs!(pc+1)"
(*<*)
proof -
  from all pc
  have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s0)  T" by (rule wtl_all)
  with pc show ?thesis by (simp add: phi_def wtc split: if_split_asm)
qed
(*>*)

lemma (in lbvs) wtl_stable:
  assumes wtl: "wtl ins c 0 s0  " 
  assumes s0:  "s0  A" and  pc:  "pc < size ins" 
  shows "stable r step τs pc"
(*<*)
proof (unfold stable_def, clarify)
  fix pc' s' assume step: "(pc',s')  set (step pc (τs ! pc))" 
                      (is "(pc',s')  set (?step pc)")
  
  from bounded pc step have pc': "pc' < size ins" by (rule boundedD)

  have tkpc: "wtl (take pc ins) c 0 s0  " (is "?s1  _") using wtl by (rule wtl_take)
  have s2: "wtl (take (pc+1) ins) c 0 s0  " (is "?s2  _") using wtl by (rule wtl_take)
  
  from wtl pc have wt_s1: "wtc c pc ?s1  " by (rule wtl_all)

  have c_Some: "pc t. pc < size ins  c!pc    τs!pc = c!pc" 
    by (simp add: phi_def)
  have c_None: "c!pc =   τs!pc = ?s1" using pc ..

  from wt_s1 pc c_None c_Some
  have inst: "wtc c pc ?s1  = wti c pc (τs!pc)"
    by (simp add: wtc split: if_split_asm)

  have "?s1  A" using pres cert s0 wtl pc by (rule wtl_pres)
  with pc c_Some cert c_None
  have "τs!pc  A" by (cases "c!pc = ") (auto dest: cert_okD1)
  with pc pres
  have step_in_A: "snd`set (?step pc)  A" by (auto dest: pres_typeD2)

  show "s' ⊑⇩r τs!pc'" 
  proof (cases "pc' = pc+1")
    case True
    with pc' cert
    have cert_in_A: "c!(pc+1)  A" by (auto dest: cert_okD1)
    from True pc' have pc1: "pc+1 < size ins" by simp
    with tkpc have "?s2 = wtc c pc ?s1" by - (rule wtl_Suc)
    with inst 
    have merge: "?s2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
    also from s2 merge have "  " (is "?merge  _") by simp
    with cert_in_A step_in_A
    have "?merge = (map snd [(p',t')  ?step pc. p'=pc+1]f c!(pc+1))"
      by (rule merge_not_top_s) 
    finally have "s' ⊑⇩r ?s2" using step_in_A cert_in_A True step 
      by (auto intro: pp_ub1')
    also from wtl pc1 have "?s2 ⊑⇩r τs!(pc+1)" by (rule wtl_suc_pc)
    also note True [symmetric]
    finally show ?thesis by simp    
  next
    case False
    from wt_s1 inst 
    have "merge c pc (?step pc) (c!(pc+1))  " by (simp add: wti)
    with step_in_A have "(pc', s')set (?step pc). pc'pc+1  s' ⊑⇩r c!pc'"
      by - (rule merge_not_top)
    with step False  have ok: "s' ⊑⇩r c!pc'" by blast
    moreover from ok have "c!pc' =   s' = " by simp
    moreover from c_Some pc'  have "c!pc'    τs!pc' = c!pc'" by auto
    ultimately show ?thesis by (cases "c!pc' = ") auto 
  qed
qed
(*>*)
  
lemma (in lbvs) phi_not_top:
  assumes wtl: "wtl ins c 0 s0  " and pc:  "pc < size ins"
  shows "τs!pc  "
(*<*)
proof (cases "c!pc = ")
  case False with pc
  have "τs!pc = c!pc" ..
  also from cert pc have "  " by (rule cert_okD4)
  finally show ?thesis .
next
  case True with pc
  have "τs!pc = wtl (take pc ins) c 0 s0" ..
  also from wtl have "  " by (rule wtl_take)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvs) phi_in_A:
  assumes wtl: "wtl ins c 0 s0  " and s0: "s0  A"
  shows "τs  list (size ins) A"
(*<*)
proof -
  { fix x assume "x  set τs"
    then obtain xs ys where "τs = xs @ x # ys" 
      by (auto simp add: in_set_conv_decomp)
    then obtain pc where pc: "pc < size τs" and x: "τs!pc = x"
      by (simp add: that [of "size xs"] nth_append)
    
    from pres cert wtl s0 pc 
    have "wtl (take pc ins) c 0 s0  A" by (auto intro!: wtl_pres)
    moreover
    from pc have "pc < size ins" by simp
    with cert have "c!pc  A" ..
    ultimately
    have "τs!pc  A" using pc by (simp add: phi_def)
    hence "x  A" using x by simp
  } 
  hence "set τs  A" ..
  thus ?thesis by (unfold list_def) simp
qed
(*>*)

lemma (in lbvs) phi0:
  assumes wtl: "wtl ins c 0 s0  " and 0: "0 < size ins"
  shows "s0 ⊑⇩r τs!0"
(*<*)
proof (cases "c!0 = ")
  case True
  with 0 have "τs!0 = wtl (take 0 ins) c 0 s0" ..
  moreover have "wtl (take 0 ins) c 0 s0 = s0" by simp
  ultimately have "τs!0 = s0" by simp
  thus ?thesis by simp
next
  case False
  with 0 have "τs!0 = c!0" ..
  moreover 
  have "wtl (take 1 ins) c 0 s0  " using wtl by (rule wtl_take)
  with 0 False 
  have "s0 ⊑⇩r c!0" by (auto simp add: neq_Nil_conv wtc split: if_split_asm)
  ultimately
  show ?thesis by simp
qed
(*>*)


theorem (in lbvs) wtl_sound:
  assumes wtl: "wtl ins c 0 s0  " and s0: "s0  A" 
  shows "τs. wt_step r  step τs"
(*<*)
proof -
  have "wt_step r  step τs"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < size τs"
    then obtain pc: "pc < size ins" by simp
    with wtl show "τs!pc  " by (rule phi_not_top)
    from wtl s0 pc show "stable r step τs pc" by (rule wtl_stable)
  qed
  thus ?thesis ..
qed
(*>*)


theorem (in lbvs) wtl_sound_strong:
  assumes wtl: "wtl ins c 0 s0  " 
  assumes s0: "s0  A" and ins: "0 < size ins"
  shows "τs  list (size ins) A. wt_step r  step τs  s0 ⊑⇩r τs!0"
(*<*)
proof -
  have "τs  list (size ins) A" using wtl s0 by (rule phi_in_A)
  moreover
  have "wt_step r  step τs"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < size τs"
    then obtain pc: "pc < size ins" by simp
    with wtl show "τs!pc  " by (rule phi_not_top)
    from wtl s0 and pc show "stable r step τs pc" by (rule wtl_stable)
  qed
  moreover from wtl ins have "s0 ⊑⇩r τs!0" by (rule phi0)
  ultimately show ?thesis by fast
qed
(*>*)

end

Theory LBVComplete

(*  Title:      HOL/MicroJava/BV/LBVComplete.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section ‹Completeness of the LBV›

theory LBVComplete
imports LBVSpec Typing_Framework
begin

definition is_target :: "'s step_type  's list  nat  bool" where
  "is_target step τs pc'  (pc s'. pc'  pc+1  pc < size τs  (pc',s')  set (step pc (τs!pc)))"

definition make_cert :: "'s step_type  's list  's  's certificate" where
  "make_cert step τs B = map (λpc. if is_target step τs pc then τs!pc else B) [0..<size τs] @ [B]"

lemma [code]:
  "is_target step τs pc' =
  list_ex (λpc. pc'  pc+1  List.member (map fst (step pc (τs!pc))) pc') [0..<size τs]"
(*<*)
  apply (simp add: list_ex_iff is_target_def member_def)
  apply force
  done
(*>*)

locale lbvc = lbv + 
  fixes τs :: "'a list" 
  fixes c :: "'a list" 
  defines cert_def: "c  make_cert step τs "

  assumes mono: "mono r step (size τs) A"
  assumes pres: "pres_type step (size τs) A" 
  assumes τs:  "pc < size τs. τs!pc  A  τs!pc  "
  assumes bounded: "bounded step (size τs)"

  assumes B_neq_T: "  " 


lemma (in lbvc) cert: "cert_ok c (size τs)   A"
(*<*)
proof (unfold cert_ok_def, intro strip conjI)  
  note [simp] = make_cert_def cert_def nth_append 

  show "c!size τs = " by simp

  fix pc assume pc: "pc < size τs" 
  from pc τs B_A show "c!pc  A" by simp
  from pc τs B_neq_T show "c!pc  " by simp
qed
(*>*)

lemmas [simp del] = split_paired_Ex

lemma (in lbvc) cert_target [intro?]:
  " (pc',s')  set (step pc (τs!pc));
      pc'  pc+1; pc < size τs; pc' < size τs 
   c!pc' = τs!pc'"
(*<*) by (auto simp add: cert_def make_cert_def nth_append is_target_def) (*>*)

lemma (in lbvc) cert_approx [intro?]:
  " pc < size τs; c!pc     c!pc = τs!pc"
(*<*) by (auto simp add: cert_def make_cert_def nth_append) (*>*)

lemma (in lbv) le_top [simp, intro]: "x <=_r "
(*<*) by (insert top) simp (*>*)
  
lemma (in lbv) merge_mono:
  assumes less:  "set ss2 {⊑r} set ss1"
  assumes x:     "x  A"
  assumes ss1:   "snd`set ss1  A"
  assumes ss2:   "snd`set ss2  A"
  shows "merge c pc ss2 x ⊑⇩r merge c pc ss1 x" (is "?s2 ⊑⇩r ?s1")
(*<*)
proof-
  have "?s1 =   ?thesis" by simp
  moreover {
    assume merge: "?s1  T" 
    from x ss1 have "?s1 =
      (if (pc',s')set ss1. pc'  pc + 1  s' ⊑⇩r c!pc'
      then (map snd [(p', t')  ss1 . p'=pc+1])f x
      else )" by (rule merge_def)  
    with merge obtain
      app: "(pc',s')set ss1. pc'  pc+1  s' ⊑⇩r c!pc'" 
           (is "?app ss1") and
      sum: "(map snd [(p',t')  ss1 . p' = pc+1]f x) = ?s1" 
           (is "?map ss1f x = _" is "?sum ss1 = _")
      by (simp split: if_split_asm)
    from app less have "?app ss2" by (blast dest: trans_r lesub_step_typeD)
    moreover {
      from ss1 have map1: "set (?map ss1)  A" by auto
      with x and semilat Semilat_axioms have "?sum ss1  A" by (auto intro!: plusplus_closed)
      with sum have "?s1  A" by simp
      moreover    
      have mapD: "x ss. x  set (?map ss)  p. (p,x)  set ss  p=pc+1" by auto
      from x map1 have "x  set (?map ss1). x ⊑⇩r ?sum ss1" by clarify (rule pp_ub1)
      with sum have "x  set (?map ss1). x ⊑⇩r ?s1" by simp
      with less have "x  set (?map ss2). x ⊑⇩r ?s1"
        by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
      moreover from map1 x have "x ⊑⇩r (?sum ss1)" by (rule pp_ub2)
      with sum have "x ⊑⇩r ?s1" by simp
      moreover from ss2 have "set (?map ss2)  A" by auto
      ultimately  have "?sum ss2 ⊑⇩r ?s1" using x by - (rule pp_lub)
    }
    moreover from x ss2 have "?s2 =
      (if (pc', s')set ss2. pc'  pc + 1  s' ⊑⇩r c!pc'
      then map snd [(p', t')  ss2 . p' = pc + 1]f x
      else )" by (rule merge_def)
    ultimately have ?thesis by simp
  }
  ultimately show ?thesis by (cases "?s1 = ") auto
qed
(*>*)

lemma (in lbvc) wti_mono:
  assumes less: "s2 ⊑⇩r s1"
  assumes pc: "pc < size τs" and s1: "s1  A" and s2: "s2  A"
  shows "wti c pc s2 ⊑⇩r wti c pc s1" (is "?s2' ⊑⇩r ?s1'")
(*<*)
proof -
  from mono pc s2 less have "set (step pc s2) {⊑r} set (step pc s1)" by (rule monoD)
  moreover from cert B_A pc have "c!Suc pc  A" by (rule cert_okD3)
  moreover from pres s1 pc have "snd`set (step pc s1)  A" by (rule pres_typeD2)
  moreover from pres s2 pc have "snd`set (step pc s2)  A" by (rule pres_typeD2)
  ultimately show ?thesis by (simp add: wti merge_mono)
qed 
(*>*)

lemma (in lbvc) wtc_mono:
  assumes less: "s2 ⊑⇩r s1"
  assumes pc: "pc < size τs" and s1: "s1  A" and s2: "s2  A"
  shows "wtc c pc s2 ⊑⇩r wtc c pc s1" (is "?s2' ⊑⇩r ?s1'")
(*<*)
proof (cases "c!pc = ")
  case True 
  moreover from less pc s1 s2 have "wti c pc s2 ⊑⇩r wti c pc s1" by (rule wti_mono)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  have "?s1' =   ?thesis" by simp
  moreover {
    assume "?s1'  " 
    with False have c: "s1 ⊑⇩r c!pc" by (simp add: wtc split: if_split_asm)
    with less have "s2 ⊑⇩r c!pc" ..
    with False c have ?thesis by (simp add: wtc)
  }
  ultimately show ?thesis by (cases "?s1' = ") auto
qed
(*>*)

lemma (in lbv) top_le_conv [simp]: " ⊑⇩r x = (x = )"
(*<*) by (insert semilat) (simp add: top top_le_conv)  (*>*)

lemma (in lbv) neq_top [simp, elim]: " x ⊑⇩r y; y     x  "
(*<*) by (cases "x = T") auto (*>*)

lemma (in lbvc) stable_wti:
  assumes stable:  "stable r step τs pc" and pc: "pc < size τs"
  shows "wti c pc (τs!pc)  "
(*<*)
proof -
  let ?step = "step pc (τs!pc)"
  from stable 
  have less: "(q,s')set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
  
  from cert B_A pc have cert_suc: "c!Suc pc  A" by (rule cert_okD3)
  moreover from τs pc have "τs!pc  A" by simp
  with pres pc have stepA: "snd`set ?step  A" by - (rule pres_typeD2)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    (if (pc',s')set ?step. pc'pc+1  s' ⊑⇩r c!pc'
    then map snd [(p',t')  ?step.p'=pc+1]f c!Suc pc
    else )" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
  moreover {
    fix pc' s' assume s': "(pc',s')  set ?step" and suc_pc: "pc'  pc+1"
    with less have "s' ⊑⇩r τs!pc'" by auto
    also from bounded pc s' have "pc' < size τs" by (rule boundedD)
    with s' suc_pc pc have "c!pc' = τs!pc'" ..
    hence "τs!pc' = c!pc'" ..
    finally have "s' ⊑⇩r c!pc'" .
  } hence "(pc',s')set ?step. pc'pc+1  s' ⊑⇩r c!pc'" by auto
  moreover from pc have "Suc pc = size τs  Suc pc < size τs" by auto
  hence "map snd [(p',t')  ?step.p'=pc+1]f c!Suc pc  " (is "?mapf _  _")
  proof (rule disjE)
    assume pc': "Suc pc = size τs"
    with cert have "c!Suc pc = " by (simp add: cert_okD2)
    moreover 
    from pc' bounded pc 
    have "(p',t')set ?step. p'pc+1" by clarify (drule boundedD, auto)
    hence "[(p',t')  ?step. p'=pc+1] = []" by (blast intro: filter_False)
    hence "?map = []" by simp
    ultimately show ?thesis by (simp add: B_neq_T)
  next
    assume pc': "Suc pc < size τs"
    from pc' τs have "τs!Suc pc  A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map  A" by auto
    moreover have "s. s  set ?map  t. (Suc pc, t)  set ?step" by auto
    with less have "s'  set ?map. s' ⊑⇩r τs!Suc pc" by auto
    moreover from pc' have "c!Suc pc ⊑⇩r τs!Suc pc" 
      by (cases "c!Suc pc = ") (auto dest: cert_approx)
    ultimately have "?mapf c!Suc pc ⊑⇩r τs!Suc pc" by (rule pp_lub)
    moreover from pc' τs have "τs!Suc pc  " by simp
    ultimately show ?thesis by auto
  qed
  ultimately have "merge c pc ?step (c!Suc pc)  " by simp
  thus ?thesis by (simp add: wti)  
qed
(*>*)

lemma (in lbvc) wti_less:
  assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
  shows "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wti ⊑⇩r _")
(*<*)
proof -
  let ?step = "step pc (τs!pc)"

  from stable
  have less: "(q,s')set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
   
  from suc_pc have pc: "pc < size τs" by simp
  with cert B_A have cert_suc: "c!Suc pc  A" by (rule cert_okD3)
  moreover from τs pc have "τs!pc  A" by simp
  with pres pc have stepA: "snd`set ?step  A" by - (rule pres_typeD2)
  moreover from stable pc have "?wti  " by (rule stable_wti)
  hence "merge c pc ?step (c!Suc pc)  " by (simp add: wti)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    map snd [(p',t')  ?step.p'=pc+1]f c!Suc pc" by (rule merge_not_top_s) 
  hence "?wti = " (is "_ = (?mapf _)" is "_ = ?sum") by (simp add: wti)
  also {
    from suc_pc τs have "τs!Suc pc  A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map  A" by auto
    moreover have "s. s  set ?map  t. (Suc pc, t)  set ?step" by auto
    with less have "s'  set ?map. s' ⊑⇩r τs!Suc pc" by auto
    moreover from suc_pc have "c!Suc pc ⊑⇩r τs!Suc pc"
      by (cases "c!Suc pc = ") (auto dest: cert_approx)
    ultimately have "?sum ⊑⇩r τs!Suc pc" by (rule pp_lub)
  }
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) stable_wtc:
  assumes stable: "stable r step τs pc" and pc: "pc < size τs"
  shows "wtc c pc (τs!pc)  "
(*<*)
proof -
  from stable pc have wti: "wti c pc (τs!pc)  " by (rule stable_wti)
  show ?thesis
  proof (cases "c!pc = ")
    case True with wti show ?thesis by (simp add: wtc)
  next
    case False
    with pc have "c!pc = τs!pc" ..    
    with False wti show ?thesis by (simp add: wtc)
  qed
qed
(*>*)

lemma (in lbvc) wtc_less:
  assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
  shows "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wtc ⊑⇩r _")
(*<*)
proof (cases "c!pc = ")
  case True
  moreover from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  from suc_pc have pc: "pc < size τs" by simp
  with stable have "?wtc  " by (rule stable_wtc)
  with False have "?wtc = wti c pc (c!pc)" 
    by (unfold wtc) (simp split: if_split_asm)
  also from pc False have "c!pc = τs!pc" .. 
  finally have "?wtc = wti c pc (τs!pc)" .
  also from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) wt_step_wtl_lemma:
  assumes wt_step: "wt_step r  step τs"
  shows "pc s. pc+size ls = size τs  s ⊑⇩r τs!pc  s  A  s 
                wtl ls c pc s  "
  (is "pc s. _  _  _  _  ?wtl ls pc s  _")
(*<*)
proof (induct ls)
  fix pc s assume "s" thus "?wtl [] pc s  " by simp
next
  fix pc s i ls
  assume "pc s. pc+size ls=size τs  s ⊑⇩r τs!pc  s  A  s  
                  ?wtl ls pc s  "
  moreover
  assume pc_l: "pc + size (i#ls) = size τs"
  hence suc_pc_l: "Suc pc + size ls = size τs" by simp
  ultimately
  have IH: "s. s ⊑⇩r τs!Suc pc  s  A  s    ?wtl ls (Suc pc) s  " .

  from pc_l obtain pc: "pc < size τs" by simp
  with wt_step have stable: "stable r step τs pc" by (simp add: wt_step_def)
  moreover note pc
  ultimately have wt_τs: "wtc c pc (τs!pc)  " by (rule stable_wtc)

  assume s_τs: "s ⊑⇩r τs!pc"
  assume sA: "s  A"
  from τs pc have τs_pc: "τs!pc  A" by simp
  from s_τs pc τs_pc sA have wt_s_τs: "wtc c pc s ⊑⇩r wtc c pc (τs!pc)" by (rule wtc_mono)
  with wt_τs have wt_s: "wtc c pc s  " by simp
  moreover assume s: "s  " 
  ultimately have "ls = []  ?wtl (i#ls) pc s  " by simp
  moreover {
    assume "ls  []" 
    with pc_l have suc_pc: "Suc pc < size τs" by (auto simp add: neq_Nil_conv)
    with stable have "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wtc_less)
    with wt_s_τs have "wtc c pc s ⊑⇩r τs!Suc pc" by (rule trans_r)      
    moreover from cert suc_pc have "c!pc  A" "c!(pc+1)  A" 
      by (auto simp add: cert_ok_def)
    from pres this sA pc have "wtc c pc s  A" by (rule wtc_pres)
    ultimately have "?wtl ls (Suc pc) (wtc c pc s)  " using IH wt_s by blast
    with s wt_s have "?wtl (i#ls) pc s  " by simp 
  }
  ultimately show "?wtl (i#ls) pc s  " by (cases ls) blast+
qed
(*>*)

theorem (in lbvc) wtl_complete:
  assumes wt: "wt_step r  step τs"
  assumes s: "s ⊑⇩r τs!0" "s  A" "s  " and eq: "size ins = size τs"
  shows "wtl ins c 0 s  "
(*<*)
proof -  
  from eq have "0+size ins = size τs" by simp
  from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed
(*>*)

end

Theory Abstract_BV

(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Gerwin Klein
    Copyright   2003 TUM

Abstract Bytecode Verifier.
*)
(*<*)
theory Abstract_BV
imports Typing_Framework_err Kildall LBVCorrect LBVComplete
begin

end
(*>*)

Theory SemiType

(*  Title:      Jinja/BV/SemiType.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section ‹The Jinja Type System as a Semilattice›

theory SemiType
imports "../Common/WellForm" "../DFA/Semilattices"
begin

definition super :: "'a prog  cname  cname"
where "super P C  fst (the (class P C))"

lemma superI:
  "(C,D)  subcls1 P  super P C = D"
  by (unfold super_def) (auto dest: subcls1D)


primrec the_Class :: "ty  cname"
where
  "the_Class (Class C) = C"

definition sup :: "'c prog  ty  ty  ty err"
where
  "sup P T1 T2 
  if is_refT T1  is_refT T2 then 
  OK (if T1 = NT then T2 else
      if T2 = NT then T1 else
      (Class (exec_lub (subcls1 P) (super P) (the_Class T1) (the_Class T2))))
  else 
  (if T1 = T2 then OK T1 else Err)"

lemma sup_def':
  "sup P = (λT1 T2.
  if is_refT T1  is_refT T2 then 
  OK (if T1 = NT then T2 else
      if T2 = NT then T1 else
      (Class (exec_lub (subcls1 P) (super P) (the_Class T1) (the_Class T2))))
  else 
  (if T1 = T2 then OK T1 else Err))"
  by (simp add: sup_def fun_eq_iff)

abbreviation
  subtype :: "'c prog  ty  ty  bool"
  where "subtype P  widen P"

definition esl :: "'c prog  ty esl"
where
  "esl P  (types P, subtype P, sup P)"


(* FIXME: move to wellform *)
lemma is_class_is_subcls:
  "wf_prog m P  is_class P C = P  C * Object"
(*<*)by (fastforce simp:is_class_def
                  elim: subcls_C_Object converse_rtranclE subcls1I
                  dest: subcls1D)
(*>*)


(* FIXME: move to wellform *)
lemma subcls_antisym:
  "wf_prog m P; P  C * D; P  D * C  C = D"
  (*<*) by (auto dest: acyclic_subcls1 acyclic_impl_antisym_rtrancl antisymD) (*>*)

(* FIXME: move to wellform *)
lemma widen_antisym:
  " wf_prog m P; P  T  U; P  U  T   T = U"
(*<*)
apply (cases T)
 apply (cases U)
 apply auto
apply (cases U)
 apply (auto elim!: subcls_antisym)
done
(*>*)

lemma order_widen [intro,simp]: 
  "wf_prog m P  order (subtype P)"
(*<*)
  apply (unfold Semilat.order_def lesub_def)
  apply (auto intro: widen_trans widen_antisym)
  done
(*>*)

(* FIXME: move to TypeRel *)
lemma NT_widen:
  "P  NT  T = (T = NT  (C. T = Class C))"
(*<*) by (cases T) auto (*>*)

(* FIXME: move to TypeRel *)
lemma Class_widen2: "P  Class C  T = (D. T = Class D  P  C * D)"
(*<*) by (cases T) auto (*>*)
 
lemma wf_converse_subcls1_impl_acc_subtype:
  "wf ((subcls1 P)^-1)  acc (subtype P)"
(*<*)
apply (unfold Semilat.acc_def lesssub_def)
apply (drule_tac p = "(subcls1 P)^-1 - Id" in wf_subset)
 apply blast
apply (drule wf_trancl)
apply (simp add: wf_eq_minimal)
apply clarify
apply (unfold lesub_def)
apply (rename_tac M T) 
apply (case_tac "C. Class C  M")
 prefer 2
 apply (case_tac T)
     apply fastforce
    apply fastforce
   apply fastforce
  apply simp
  apply (rule_tac x = NT in bexI)
   apply (rule allI)
   apply (rule impI, erule conjE) 
   apply (clarsimp simp add: NT_widen)
  apply simp
 apply clarsimp
apply (erule_tac x = "{C. Class C : M}" in allE)
apply auto
apply (rename_tac D)
apply (rule_tac x = "Class D" in bexI)
 prefer 2
 apply assumption
apply clarify
apply (clarsimp simp: Class_widen2)
apply (insert rtrancl_r_diff_Id [symmetric, of "subcls1 P"])
apply simp
apply (erule rtranclE)
 apply blast
apply (drule rtrancl_converseI)
apply (subgoal_tac "((subcls1 P)-Id)^-1 = ((subcls1 P)^-1 - Id)")
 prefer 2
 apply blast
apply simp
apply (blast intro: rtrancl_into_trancl2)
done
(*>*)

lemma wf_subtype_acc [intro, simp]:
  "wf_prog wf_mb P  acc (subtype P)"
(*<*) by (rule wf_converse_subcls1_impl_acc_subtype, rule wf_subcls1) (*>*)

lemma exec_lub_refl [simp]: "exec_lub r f T T = T"
(*<*) by (simp add: exec_lub_def while_unfold) (*>*)

lemma closed_err_types:
  "wf_prog wf_mb P  closed (err (types P)) (lift2 (sup P))"
(*<*)
  apply (unfold closed_def plussub_def lift2_def sup_def')
  apply (frule acyclic_subcls1)
  apply (frule single_valued_subcls1)
  apply (auto simp: is_type_def is_refT_def is_class_is_subcls split: err.split ty.splits)
  apply (blast dest!: is_lub_exec_lub is_lubD is_ubD intro!: is_ubI superI)
  done
(*>*)


lemma sup_subtype_greater:
  " wf_prog wf_mb P; is_type P t1; is_type P t2; sup P t1 t2 = OK s  
   subtype P t1 s  subtype P t2 s"
(*<*)
proof -
  assume wf_prog: "wf_prog wf_mb P"
 
  { fix c1 c2
    assume is_class: "is_class P c1" "is_class P c2"
    with wf_prog 
    obtain 
      "P  c1 * Object"
      "P  c2 * Object"
      by (blast intro: subcls_C_Object)
    with single_valued_subcls1[OF wf_prog]
    obtain u where
      "is_lub ((subcls1 P)^* ) c1 c2 u"      
      by (blast dest: single_valued_has_lubs)
    moreover
    note acyclic_subcls1[OF wf_prog]
    moreover
    have "x y. (x, y)  subcls1 P  super P x = y"
      by (blast intro: superI)
    ultimately
    have "P  c1 * exec_lub (subcls1 P) (super P) c1 c2 
          P  c2 * exec_lub (subcls1 P) (super P) c1 c2"
      by (simp add: exec_lub_conv) (blast dest: is_lubD is_ubD)
  } note this [simp]

  assume "is_type P t1" "is_type P t2" "sup P t1 t2 = OK s"
  thus ?thesis
    apply (unfold sup_def) 
    apply (cases s)
    apply (auto simp add: is_refT_def split: if_split_asm)
    done
qed
(*>*)

lemma sup_subtype_smallest:
  " wf_prog wf_mb P; is_type P a; is_type P b; is_type P c; 
      subtype P a c; subtype P b c; sup P a b = OK d 
   subtype P d c"
(*<*)
proof -
  assume wf_prog: "wf_prog wf_mb P"

  { fix c1 c2 D
    assume is_class: "is_class P c1" "is_class P c2"
    assume le: "P  c1 * D" "P  c2 * D"
    from wf_prog is_class
    obtain 
      "P  c1 * Object"
      "P  c2 * Object"
      by (blast intro: subcls_C_Object)
    with single_valued_subcls1[OF wf_prog]
    obtain u where
      lub: "is_lub ((subcls1 P)^* ) c1 c2 u"
      by (blast dest: single_valued_has_lubs)   
    with acyclic_subcls1[OF wf_prog]
    have "exec_lub (subcls1 P) (super P) c1 c2 = u"
      by (blast intro: superI exec_lub_conv)
    moreover
    from lub le
    have "P  u * D" 
      by (simp add: is_lub_def is_ub_def)
    ultimately     
    have "P  exec_lub (subcls1 P) (super P) c1 c2 * D"
      by blast
  } note this [intro]

  have [dest!]:
    "C T. P  Class C  T  D. T=Class D  P  C * D"
    by (frule Class_widen, auto)

  assume "is_type P a" "is_type P b" "is_type P c"
         "subtype P a c" "subtype P b c" "sup P a b = OK d"
  thus ?thesis
    by (auto simp add: sup_def is_refT_def
             split: if_split_asm)
qed
(*>*)

lemma sup_exists:
  " subtype P a c; subtype P b c   T. sup P a b = OK T"
(*<*)
apply (unfold sup_def)
apply (cases b)
apply auto
apply (cases a)
apply auto
apply (cases a)
apply auto
done
(*>*)

lemma err_semilat_JType_esl:
  "wf_prog wf_mb P  err_semilat (esl P)"
(*<*)
proof -
  assume wf_prog: "wf_prog wf_mb P"  
  hence "order (subtype P)"..
  moreover from wf_prog
  have "closed (err (types P)) (lift2 (sup P))"
    by (rule closed_err_types)
  moreover
  from wf_prog have
    "(xerr (types P). yerr (types P). xErr.le (subtype P) xlift2 (sup P) y)  
     (xerr (types P). yerr (types P). yErr.le (subtype P) xlift2 (sup P) y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_subtype_greater split: err.split)
  moreover from wf_prog have
    "xerr (types P). yerr (types P). zerr (types P). 
    xErr.le (subtype P) z  yErr.le (subtype P) z  xlift2 (sup P) yErr.le (subtype P) z"
    by (unfold lift2_def plussub_def lesub_def Err.le_def)
       (auto intro: sup_subtype_smallest dest:sup_exists split: err.split)
  ultimately show ?thesis by (simp add: esl_def semilat_def sl_def Err.sl_def)
qed
(*>*)


end

Theory JVM_SemiType

(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

section ‹The JVM Type System as Semilattice›

theory JVM_SemiType imports SemiType begin

type_synonym tyl = "ty err list"
type_synonym tys = "ty list"
type_synonym tyi = "tys × tyl"
type_synonym tyi' = "tyi option"
type_synonym tym = "tyi' list"
type_synonym tyP = "mname  cname  tym"


definition stk_esl :: "'c prog  nat  tys esl"
where
  "stk_esl P mxs  upto_esl mxs (SemiType.esl P)"

definition loc_sl :: "'c prog  nat  tyl sl"
where
  "loc_sl P mxl  Listn.sl mxl (Err.sl (SemiType.esl P))"

definition sl :: "'c prog  nat  nat  tyi' err sl"
where
  "sl P mxs mxl 
  Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"


definition states :: "'c prog  nat  nat  tyi' err set"
where "states P mxs mxl  fst(sl P mxs mxl)"

definition le :: "'c prog  nat  nat  tyi' err ord"
where
  "le P mxs mxl  fst(snd(sl P mxs mxl))"

definition sup :: "'c prog  nat  nat  tyi' err binop"
where
  "sup P mxs mxl  snd(snd(sl P mxs mxl))"


definition sup_ty_opt :: "['c prog,ty err,ty err]  bool" 
    ("_  _  _" [71,71,71] 70)
where
  "sup_ty_opt P  Err.le (subtype P)"

definition sup_state :: "['c prog,tyi,tyi]  bool"   
    ("_  _ i _" [71,71,71] 70)
where
  "sup_state P  Product.le (Listn.le (subtype P)) (Listn.le (sup_ty_opt P))"

definition sup_state_opt :: "['c prog,tyi',tyi']  bool" 
    ("_  _ ≤'' _" [71,71,71] 70)
where
  "sup_state_opt P  Opt.le (sup_state P)"

abbreviation
  sup_loc :: "['c prog,tyl,tyl]  bool"  ("_  _ [≤] _"  [71,71,71] 70)
  where "P  LT [≤] LT'  list_all2 (sup_ty_opt P) LT LT'"

notation (ASCII)
  sup_ty_opt  ("_ |- _ <=T _" [71,71,71] 70) and
  sup_state  ("_ |- _ <=i _"  [71,71,71] 70) and
  sup_state_opt  ("_ |- _ <=' _"  [71,71,71] 70) and
  sup_loc  ("_ |- _ [<=T] _"  [71,71,71] 70)


subsection "Unfolding"

lemma JVM_states_unfold: 
  "states P mxs mxl  err(opt((Union {list n (types P) |n. n <= mxs}) ×
                                 list mxl (err(types P))))"
(*<*)
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma JVM_le_unfold:
 "le P m n  
  Err.le(Opt.le(Product.le(Listn.le(subtype P))(Listn.le(Err.le(subtype P)))))" 
(*<*)
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def  
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def) 
  apply simp
  done
(*>*)
    
lemma sl_def2:
  "JVM_SemiType.sl P mxs mxl  
  (states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
(*<*) by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp (*>*)


lemma JVM_le_conv:
  "le P m n (OK t1) (OK t2) = P  t1 ≤' t2"
(*<*) by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def  
                sup_state_def sup_ty_opt_def) (*>*)

lemma JVM_le_Err_conv:
  "le P m n = Err.le (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def  
             sup_ty_opt_def JVM_le_unfold) simp (*>*)

lemma err_le_unfold [iff]: 
  "Err.le r (OK a) (OK b) = r a b"
(*<*) by (simp add: Err.le_def lesub_def) (*>*)
  

subsection ‹Semilattice›

lemma order_sup_state_opt [intro, simp]: 
  "wf_prog wf_mb P  order (sup_state_opt P)"   
(*<*) by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast (*>*)

lemma semilat_JVM [intro?]:
  "wf_prog wf_mb P  semilat (JVM_SemiType.sl P mxs mxl)"
(*<*)
  apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)  
  apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl 
                      Listn_sl err_semilat_JType_esl)
  done
(*>*)

lemma acc_JVM [intro]:
  "wf_prog wf_mb P  acc (JVM_SemiType.le P mxs mxl)"
(*<*) by (unfold JVM_le_unfold) blast (*>*)


subsection ‹Widening with ⊤›

lemma subtype_refl[iff]: "subtype P t t" (*<*) by (simp add: fun_of_def) (*>*)

lemma sup_ty_opt_refl [iff]: "P  T  T"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (fold lesub_def)
  apply (rule le_err_refl)
  apply (simp add: lesub_def)
  done
(*>*)

lemma Err_any_conv [iff]: "P  Err  T = (T = Err)"
(*<*) by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def]) (*>*)

lemma any_Err [iff]: "P  T  Err"
(*<*) by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def]) (*>*)

lemma OK_OK_conv [iff]:
  "P  OK T  OK T' = P  T  T'"
(*<*) by (simp add: sup_ty_opt_def fun_of_def) (*>*)

lemma any_OK_conv [iff]:
  "P  X  OK T' = (T. X = OK T  P  T  T')"
(*<*)
  apply (unfold sup_ty_opt_def) 
  apply (rule le_OK_conv [simplified lesub_def])
  done  
(*>*)

lemma OK_any_conv:
 "P  OK T  X = (X = Err  (T'. X = OK T'  P  T  T'))"
(*<*)
  apply (unfold sup_ty_opt_def) 
  apply (rule OK_le_conv [simplified lesub_def])
  done
(*>*)

lemma sup_ty_opt_trans [intro?, trans]:
  "P  a  b; P  b  c  P  a  c"
(*<*) by (auto intro: widen_trans  
           simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
           split: err.splits) (*>*)


subsection "Stack and Registers"

lemma stk_convert:
  "P  ST [≤] ST' = Listn.le (subtype P) ST ST'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_refl [iff]: "P  LT [≤] LT"
(*<*) by (rule list_all2_refl) simp (*>*)

lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P

lemma sup_loc_def:
  "P  LT [≤] LT'  Listn.le (sup_ty_opt P) LT LT'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_widens_conv [iff]:
  "P  map OK Ts [≤] map OK Ts' = P  Ts [≤] Ts'"
(*<*)
  by (simp add: list_all2_map1 list_all2_map2)
(*>*)


lemma sup_loc_trans [intro?, trans]:
  "P  a [≤] b; P  b [≤] c  P  a [≤] c"
(*<*) by (rule list_all2_trans, rule sup_ty_opt_trans) (*>*)


subsection "State Type"

lemma sup_state_conv [iff]:
  "P  (ST,LT) i (ST',LT') = (P  ST [≤] ST'  P  LT [≤] LT')"
(*<*) by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def) (*>*)
  
lemma sup_state_conv2:
  "P  s1 i s2 = (P  fst s1 [≤] fst s2  P  snd s1 [≤] snd s2)"
(*<*) by (cases s1, cases s2) simp (*>*)

lemma sup_state_refl [iff]: "P  s i s"
(*<*) by (auto simp add: sup_state_conv2) (*>*)

lemma sup_state_trans [intro?, trans]:
  "P  a i b; P  b i c  P  a i c"
(*<*) by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2) (*>*)


lemma sup_state_opt_None_any [iff]:
  "P  None ≤' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_any_None [iff]:
  "P  s ≤' None = (s = None)"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_Some_Some [iff]:
  "P  Some a ≤' Some b = P  a i b"  
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_any_Some:
  "P  (Some s) ≤' X = (s'. X = Some s'  P  s i s')"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_refl [iff]: "P  s ≤' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_trans [intro?, trans]:
  "P  a ≤' b; P  b ≤' c  P  a ≤' c"
(*<*)
  apply (unfold sup_state_opt_def Opt.le_def lesub_def)
  apply (simp del: split_paired_All)
  apply (rule sup_state_trans, assumption+)
  done
(*>*)

end

Theory Effect

(*  Title:      HOL/MicroJava/BV/Effect.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section ‹Effect of Instructions on the State Type›

theory Effect
imports JVM_SemiType "../JVM/JVMExceptions"
begin

― ‹FIXME›
locale prog =
  fixes P :: "'a prog"

locale jvm_method = prog +
  fixes mxs :: nat  
  fixes mxl0 :: nat   
  fixes Ts :: "ty list" 
  fixes Tr :: ty
  fixes "is" :: "instr list" 
  fixes xt :: ex_table

  fixes mxl :: nat
  defines mxl_def: "mxl  1+size Ts+mxl0"

text ‹Program counter of successor instructions:›
primrec succs :: "instr  tyi  pc  pc list" where
  "succs (Load idx) τ pc     = [pc+1]"
| "succs (Store idx) τ pc    = [pc+1]"
| "succs (Push v) τ pc       = [pc+1]"
| "succs (Getfield F C) τ pc = [pc+1]"
| "succs (Putfield F C) τ pc = [pc+1]"
| "succs (New C) τ pc        = [pc+1]"
| "succs (Checkcast C) τ pc  = [pc+1]"
| "succs Pop τ pc            = [pc+1]"
| "succs IAdd τ pc           = [pc+1]"
| "succs CmpEq τ pc          = [pc+1]"
| succs_IfFalse:
    "succs (IfFalse b) τ pc    = [pc+1, nat (int pc + b)]"
| succs_Goto:
    "succs (Goto b) τ pc       = [nat (int pc + b)]"
| succs_Return:
    "succs Return τ pc         = []"  
| succs_Invoke:
    "succs (Invoke M n) τ pc   = (if (fst τ)!n = NT then [] else [pc+1])"
| succs_Throw:
    "succs Throw τ pc          = []"

text "Effect of instruction on the state type:"

fun the_class:: "ty  cname" where
  "the_class (Class C) = C"

fun effi :: "instr × 'm prog × tyi  tyi" where
  effi_Load:
    "effi (Load n,  P, (ST, LT))          = (ok_val (LT ! n) # ST, LT)"
| effi_Store:
    "effi (Store n, P, (T#ST, LT))        = (ST, LT[n:= OK T])"
| effi_Push:
    "effi (Push v, P, (ST, LT))             = (the (typeof v) # ST, LT)"
| effi_Getfield:
    "effi (Getfield F C, P, (T#ST, LT))    = (snd (field P C F) # ST, LT)"
| effi_Putfield:
   "effi (Putfield F C, P, (T1#T2#ST, LT)) = (ST,LT)"
| effi_New:
   "effi (New C, P, (ST,LT))               = (Class C # ST, LT)"
| effi_Checkcast:
   "effi (Checkcast C, P, (T#ST,LT))       = (Class C # ST,LT)"
| effi_Pop:
   "effi (Pop, P, (T#ST,LT))               = (ST,LT)"
| effi_IAdd:
   "effi (IAdd, P,(T1#T2#ST,LT))           = (Integer#ST,LT)"
| effi_CmpEq:
   "effi (CmpEq, P, (T1#T2#ST,LT))         = (Boolean#ST,LT)"
| effi_IfFalse:
   "effi (IfFalse b, P, (T1#ST,LT))        = (ST,LT)"
| effi_Invoke:
   "effi (Invoke M n, P, (ST,LT))          =
    (let C = the_class (ST!n); (D,Ts,Tr,b) = method P C M
     in (Tr # drop (n+1) ST, LT))"
| effi_Goto:
   "effi (Goto n, P, s)                    = s"

fun is_relevant_class :: "instr  'm prog  cname  bool" where
  rel_Getfield:
    "is_relevant_class (Getfield F D) = (λP C. P  NullPointer * C)" 
| rel_Putfield:
    "is_relevant_class (Putfield F D) = (λP C. P  NullPointer * C)" 
| rel_Checcast:
    "is_relevant_class (Checkcast D)  = (λP C. P  ClassCast * C)" 
| rel_New:
    "is_relevant_class (New D)        = (λP C. P  OutOfMemory * C)" 
| rel_Throw:
    "is_relevant_class Throw          = (λP C. True)"
| rel_Invoke:
    "is_relevant_class (Invoke M n)   = (λP C. True)"
| rel_default:
    "is_relevant_class i              = (λP C. False)"

definition is_relevant_entry :: "'m prog  instr  pc  ex_entry  bool" where
  "is_relevant_entry P i pc e  (let (f,t,C,h,d) = e in is_relevant_class i P C  pc  {f..<t})"

definition relevant_entries :: "'m prog  instr  pc  ex_table  ex_table" where
  "relevant_entries P i pc = filter (is_relevant_entry P i pc)"

definition xcpt_eff :: "instr  'm prog  pc  tyi 
                ex_table  (pc × tyi') list" where    
  "xcpt_eff i P pc τ et = (let (ST,LT) = τ in 
  map (λ(f,t,C,h,d). (h, Some (Class C#drop (size ST - d) ST, LT))) (relevant_entries P i pc et))"

definition norm_eff :: "instr  'm prog  nat  tyi  (pc × tyi') list" where
  "norm_eff i P pc τ = map (λpc'. (pc',Some (effi (i,P,τ)))) (succs i τ pc)"

definition eff :: "instr  'm prog  pc  ex_table  tyi'  (pc × tyi') list" where
  "eff i P pc et t = (case t of           
    None  []          
  | Some τ  (norm_eff i P pc τ) @ (xcpt_eff i P pc τ et))"


lemma eff_None:
  "eff i P pc xt None = []"
by (simp add: eff_def)

lemma eff_Some:
  "eff i P pc xt (Some τ) = norm_eff i P pc τ @ xcpt_eff i P pc τ xt"
by (simp add: eff_def)

(* FIXME: getfield, ∃T D. P ⊢ C sees F:T in D ∧ .. *)

text "Conditions under which eff is applicable:"

fun appi :: "instr × 'm prog × pc × nat × ty × tyi  bool" where
  appi_Load:
    "appi (Load n, P, pc, mxs, Tr, (ST,LT)) = 
    (n < length LT  LT ! n  Err  length ST < mxs)"
| appi_Store:
    "appi (Store n, P, pc, mxs, Tr, (T#ST, LT)) = 
    (n < length LT)"
| appi_Push:
    "appi (Push v, P, pc, mxs, Tr, (ST,LT)) = 
     (length ST < mxs  typeof v  None)"
| appi_Getfield:
    "appi (Getfield F C, P, pc, mxs, Tr, (T#ST, LT)) = 
    (Tf. P  C sees F:Tf in C  P  T  Class C)"
| appi_Putfield:
    "appi (Putfield F C, P, pc, mxs, Tr, (T1#T2#ST, LT)) = 
    (Tf. P  C sees F:Tf in C  P  T2  (Class C)  P  T1  Tf)" 
| appi_New:
    "appi (New C, P, pc, mxs, Tr, (ST,LT)) = 
    (is_class P C  length ST < mxs)"
| appi_Checkcast:
    "appi (Checkcast C, P, pc, mxs, Tr, (T#ST,LT)) = 
    (is_class P C  is_refT T)"
| appi_Pop:
    "appi (Pop, P, pc, mxs, Tr, (T#ST,LT)) = 
    True"
| appi_IAdd:
    "appi (IAdd, P, pc, mxs, Tr, (T1#T2#ST,LT)) = (T1 = T2  T1 = Integer)"
| appi_CmpEq:
    "appi (CmpEq, P, pc, mxs, Tr, (T1#T2#ST,LT)) =
    (T1 = T2  is_refT T1  is_refT T2)"
| appi_IfFalse:
    "appi (IfFalse b, P, pc, mxs, Tr, (Boolean#ST,LT)) = 
    (0  int pc + b)"
| appi_Goto:
    "appi (Goto b, P, pc, mxs, Tr, s) = 
    (0  int pc + b)"
| appi_Return:
    "appi (Return, P, pc, mxs, Tr, (T#ST,LT)) = 
    (P  T  Tr)"
| appi_Throw:
    "appi (Throw, P, pc, mxs, Tr, (T#ST,LT)) = 
    is_refT T"
| appi_Invoke:
    "appi (Invoke M n, P, pc, mxs, Tr, (ST,LT)) =
    (n < length ST  
    (ST!n  NT 
      (C D Ts T m. ST!n = Class C  P  C sees M:Ts  T = m in D 
                    P  rev (take n ST) [≤] Ts)))"
  
| appi_default:
    "appi (i,P, pc,mxs,Tr,s) = False"


definition xcpt_app :: "instr  'm prog  pc  nat  ex_table  tyi  bool" where
  "xcpt_app i P pc mxs xt τ  ((f,t,C,h,d)  set (relevant_entries P i pc xt). is_class P C  d  size (fst τ)  d < mxs)"

definition app :: "instr  'm prog  nat  ty  nat  nat  ex_table  tyi'  bool" where
  "app i P mxs Tr pc mpc xt t = (case t of None  True | Some τ  
  appi (i,P,pc,mxs,Tr,τ)  xcpt_app i P pc mxs xt τ  
  ((pc',τ')  set (eff i P pc xt t). pc' < mpc))"


lemma app_Some:
  "app i P mxs Tr pc mpc xt (Some τ) = 
  (appi (i,P,pc,mxs,Tr,τ)  xcpt_app i P pc mxs xt τ  
  ((pc',s')  set (eff i P pc xt (Some τ)). pc' < mpc))"
by (simp add: app_def)

locale eff = jvm_method +
  fixes effi and appi and eff and app 
  fixes norm_eff and xcpt_app and xcpt_eff

  fixes mpc
  defines "mpc  size is"

  defines "effi i τ  Effect.effi (i,P,τ)"
  notes effi_simps [simp] = Effect.effi.simps [where P = P, folded effi_def]

  defines "appi i pc τ  Effect.appi (i, P, pc, mxs, Tr, τ)"
  notes appi_simps [simp] = Effect.appi.simps [where P=P and mxs=mxs and Tr=Tr, folded appi_def]

  defines "xcpt_eff i pc τ  Effect.xcpt_eff i P pc τ xt"
  notes xcpt_eff = Effect.xcpt_eff_def [of _ P _ _ xt, folded xcpt_eff_def]

  defines "norm_eff i pc τ  Effect.norm_eff i P pc τ"
  notes norm_eff = Effect.norm_eff_def [of _ P, folded norm_eff_def effi_def]

  defines "eff i pc  Effect.eff i P pc xt"
  notes eff = Effect.eff_def [of _ P  _ xt, folded eff_def norm_eff_def xcpt_eff_def]

  defines "xcpt_app i pc τ  Effect.xcpt_app i P pc mxs xt τ"
  notes xcpt_app = Effect.xcpt_app_def [of _ P _ mxs xt, folded xcpt_app_def]

  defines "app i pc  Effect.app i P mxs Tr pc mpc xt"
  notes app = Effect.app_def [of _ P mxs Tr _ mpc xt, folded app_def xcpt_app_def appi_def eff_def]


lemma length_cases2:
  assumes "LT. P ([],LT)"
  assumes "l ST LT. P (l#ST,LT)"
  shows "P s"
  by (cases s, cases "fst s") (auto intro!: assms)


lemma length_cases3:
  assumes "LT. P ([],LT)"
  assumes "l LT. P ([l],LT)"
  assumes "l ST LT. P (l#ST,LT)"
  shows "P s"
(*<*)
proof -
  obtain xs LT where s: "s = (xs,LT)" by (cases s)
  show ?thesis
  proof (cases xs)
    case Nil with assms s show ?thesis by simp
  next
    fix l xs' assume "xs = l#xs'"
    with assms s show ?thesis by simp
  qed
qed
(*>*)

lemma length_cases4:
  assumes "LT. P ([],LT)"
  assumes "l LT. P ([l],LT)"
  assumes "l l' LT. P ([l,l'],LT)"
  assumes "l l' ST LT. P (l#l'#ST,LT)"
  shows "P s"
(*<*)
proof -
  obtain xs LT where s: "s = (xs,LT)" by (cases s)
  show ?thesis
  proof (cases xs)
    case Nil with assms s show ?thesis by simp
  next
    fix l xs' assume xs: "xs = l#xs'"
    thus ?thesis
    proof (cases xs')
      case Nil with assms s xs show ?thesis by simp
    next
      fix l' ST assume "xs' = l'#ST"
     with assms s xs show ?thesis by simp
    qed
  qed
qed
(*>*)

text ‹
\medskip
simp rules for @{term app}
lemma appNone[simp]: "app i P mxs Tr pc mpc et None = True" 
  by (simp add: app_def)


lemma appLoad[simp]:
"appi (Load idx, P, Tr, mxs, pc, s) = (ST LT. s = (ST,LT)  idx < length LT  LT!idx  Err  length ST < mxs)"
  by (cases s, simp)

lemma appStore[simp]:
"appi (Store idx,P,pc,mxs,Tr,s) = (ts ST LT. s = (ts#ST,LT)  idx < length LT)"
  by (rule length_cases2, auto)

lemma appPush[simp]:
"appi (Push v,P,pc,mxs,Tr,s) =
 (ST LT. s = (ST,LT)  length ST < mxs  typeof v  None)"
  by (cases s, simp)

lemma appGetField[simp]:
"appi (Getfield F C,P,pc,mxs,Tr,s) = 
 ( oT vT ST LT. s = (oT#ST, LT)  
  P  C sees F:vT in C  P  oT  (Class C))"
  by (rule length_cases2 [of _ s]) auto

lemma appPutField[simp]:
"appi (Putfield F C,P,pc,mxs,Tr,s) = 
 ( vT vT' oT ST LT. s = (vT#oT#ST, LT) 
  P  C sees F:vT' in C  P  oT  (Class C)  P  vT  vT')"
  by (rule length_cases4 [of _ s], auto)

lemma appNew[simp]:
  "appi (New C,P,pc,mxs,Tr,s) = 
  (ST LT. s=(ST,LT)  is_class P C  length ST < mxs)"
  by (cases s, simp)

lemma appCheckcast[simp]: 
  "appi (Checkcast C,P,pc,mxs,Tr,s) =  
  (T ST LT. s = (T#ST,LT)  is_class P C  is_refT T)"
  by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)

lemma appiPop[simp]: 
"appi (Pop,P,pc,mxs,Tr,s) = (ts ST LT. s = (ts#ST,LT))"
  by (rule length_cases2, auto)

lemma appIAdd[simp]:
"appi (IAdd,P,pc,mxs,Tr,s) = (ST LT. s = (Integer#Integer#ST,LT))"
(*<*)
proof -
  obtain ST LT where [simp]: "s = (ST,LT)" by (cases s)
  have "ST = []  (T. ST = [T])  (T1 T2 ST'. ST = T1#T2#ST')"
    by (cases ST, auto, case_tac list, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by (cases T, auto) }
  moreover
  { fix T1 T2 ST' assume "ST = T1#T2#ST'"
    hence ?thesis by (cases T1, auto)
  }
  ultimately show ?thesis by blast
qed
(*>*)


lemma appIfFalse [simp]:
"appi (IfFalse b,P,pc,mxs,Tr,s) = 
  (ST LT. s = (Boolean#ST,LT)  0  int pc + b)"
(*<*)
  apply (rule length_cases2)
  apply simp
  apply (case_tac l) 
  apply auto
  done
(*>*)

lemma appCmpEq[simp]:
"appi (CmpEq,P,pc,mxs,Tr,s) = 
  (T1 T2 ST LT. s = (T1#T2#ST,LT)  (¬is_refT T1  T2 = T1  is_refT T1  is_refT T2))"
  by (rule length_cases4, auto)

lemma appReturn[simp]:
"appi (Return,P,pc,mxs,Tr,s) = (T ST LT. s = (T#ST,LT)  P  T  Tr)" 
  by (rule length_cases2, auto)

lemma appThrow[simp]:
  "appi (Throw,P,pc,mxs,Tr,s) = (T ST LT. s=(T#ST,LT)  is_refT T)"
  by (rule length_cases2, auto)  

lemma effNone: 
  "(pc', s')  set (eff i P pc et None)  s' = None"
  by (auto simp add: eff_def xcpt_eff_def norm_eff_def)


text ‹some helpers to make the specification directly executable:›
lemma relevant_entries_append [simp]:
  "relevant_entries P i pc (xt @ xt') = relevant_entries P i pc xt @ relevant_entries P i pc xt'"
  by (unfold relevant_entries_def) simp

lemma xcpt_app_append [iff]:
  "xcpt_app i P pc mxs (xt@xt') τ = (xcpt_app i P pc mxs xt τ  xcpt_app i P pc mxs xt' τ)"
  by (unfold xcpt_app_def) fastforce

lemma xcpt_eff_append [simp]:
  "xcpt_eff i P pc τ (xt@xt') = xcpt_eff i P pc τ xt @ xcpt_eff i P pc τ xt'"
 by (unfold xcpt_eff_def, cases τ) simp

lemma app_append [simp]:
  "app i P pc T mxs mpc (xt@xt') τ = (app i P pc T mxs mpc xt τ  app i P pc T mxs mpc xt' τ)"
  by (unfold app_def eff_def) auto

end

Theory EffectMono

(*  Title:      HOL/MicroJava/BV/EffMono.thy

    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section ‹Monotonicity of eff and app›

theory EffectMono imports Effect begin

declare not_Err_eq [iff]

lemma appi_mono: 
  assumes wf: "wf_prog p P"
  assumes less: "P  τ i τ'"
  shows "appi (i,P,mxs,mpc,rT,τ')  appi (i,P,mxs,mpc,rT,τ)"
(*<*)
proof -
  assume app: "appi (i,P,mxs,mpc,rT,τ')"
  
  obtain ST LT ST' LT' where
    [simp]: "τ = (ST,LT)" and
    [simp]: "τ' = (ST',LT')" 
    by (cases τ, cases τ')

  from less have [simp]: "size ST = size ST'" and [simp]: "size LT = size LT'"
    by (auto dest: list_all2_lengthD)

  note [iff] = list_all2_Cons2 widen_Class  
  note [simp] = fun_of_def 

  from app less show "appi (i,P,mxs,mpc,rT,τ)"
  proof (cases i)
    case Load
    with app less show ?thesis by (auto dest!: list_all2_nthD)
  next
    case (Invoke M n)
    with app have n: "n < size ST'" by simp
    
    { assume "ST!n = NT" hence ?thesis using n app Invoke by simp }
    moreover {
      assume "ST'!n = NT"
      moreover with n less have "ST!n = NT" 
        by (auto dest: list_all2_nthD)
      ultimately have ?thesis using n app Invoke by simp
    }
    moreover {
      assume ST: "ST!n  NT" and ST': "ST'!n  NT" 

      from ST' app Invoke obtain D Ts T m C' where
        D:   "ST' ! n = Class D" and
        Ts:  "P  rev (take n ST') [≤] Ts" and
        D_M: "P  D sees M: TsT = m in C'"
        by auto

      from n D less have "P  ST!n  ST'!n" 
        by (fastforce dest: list_all2_nthD2)
      with D ST obtain D' where
        D': "ST!n = Class D'" and DsubC: "P  D' * D" by auto

      from wf D_M DsubC obtain Ts' T' m' C'' where
        D'_M: "P  D' sees M: Ts'T' = m' in C''" and
        Ts': "P  Ts [≤] Ts'"
        by (blast dest: sees_method_mono) 

      from less have "P  rev (take n ST) [≤] rev (take n ST')" by simp
      also note Ts also note Ts' 
      finally have "P  rev (take n ST) [≤] Ts'" .
      with D'_M D' app less Invoke have ?thesis by fastforce
    }
    ultimately show ?thesis by blast
  next 
    case Getfield
    with app less show ?thesis by (fastforce intro: rtrancl_trans)
  next
    case (Putfield F C)
    with app less show ?thesis by (fastforce intro: widen_trans rtrancl_trans)
  next
    case Return
    with app less show ?thesis by (fastforce intro: widen_trans)
  qed (auto elim!: refTE not_refTE)
qed
(*>*)

lemma succs_mono:
  assumes wf: "wf_prog p P" and appi: "appi (i,P,mxs,mpc,rT,τ')"
  shows "P  τ i τ'  set (succs i τ pc)  set (succs i τ' pc)"
(*<*)
proof (cases i)
  case (Invoke M n)
  obtain ST LT ST' LT' where 
    [simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ') 
  assume "P  τ i τ'"
  moreover
  with appi Invoke have "n < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P  ST!n  ST'!n" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with Invoke show ?thesis by auto 
qed auto
(*>*)
  

lemma app_mono: 
  assumes wf: "wf_prog p P"
  assumes less': "P  τ ≤' τ'"
  shows "app i P m rT pc mpc xt τ'  app i P m rT pc mpc xt τ"
(*<*)
proof (cases τ)
  case None thus ?thesis by simp
next
  case (Some τ1) 
  moreover
  with less' obtain τ2 where τ2: "τ' = Some τ2" by (cases τ') auto
  ultimately have less: "P  τ1 i τ2" using less' by simp
  
  assume "app i P m rT pc mpc xt τ'"
  with Some τ2 obtain
    appi: "appi (i, P, pc, m, rT, τ2)" and
    xcpt: "xcpt_app i P pc m xt τ2" and
    succs: "(pc',s')set (eff i P pc xt (Some τ2)). pc' < mpc"
    by (auto simp add: app_def)
  
  from wf less appi have "appi (i, P, pc, m, rT, τ1)" by (rule appi_mono)
  moreover
  from less have "size (fst τ1) = size (fst τ2)" 
    by (cases τ1, cases τ2) (auto dest: list_all2_lengthD)
  with xcpt have "xcpt_app i P pc m xt τ1" by (simp add: xcpt_app_def)
  moreover
  from wf appi less have "pc. set (succs i τ1 pc)  set (succs i τ2 pc)"
    by (blast dest: succs_mono)
  with succs
  have "(pc',s')set (eff i P pc xt (Some τ1)). pc' < mpc"
    by (cases τ1, cases τ2)
       (auto simp add: eff_def norm_eff_def xcpt_eff_def dest: bspec)
  ultimately
  show ?thesis using Some by (simp add: app_def)
qed
(*>*)


lemma effi_mono:
  assumes wf: "wf_prog p P"
  assumes less: "P  τ i τ'"
  assumes appi: "app i P m rT pc mpc xt (Some τ')"
  assumes succs: "succs i τ pc  []"  "succs i τ' pc  []"
  shows "P  effi (i,P,τ) i effi (i,P,τ')"
(*<*)
proof -
  obtain ST LT ST' LT' where
    [simp]: "τ = (ST,LT)" and
    [simp]: "τ' = (ST',LT')" 
    by (cases τ, cases τ')
  
  note [simp] = eff_def app_def fun_of_def 

  from less have "P  (Some τ) ≤' (Some τ')" by simp
  from wf this appi 
  have app: "app i P m rT pc mpc xt (Some τ)" by (rule app_mono)

  from less app appi show ?thesis
  proof (cases i)
    case Throw with succs have False by simp
    thus ?thesis ..
  next
    case Return with succs have False by simp
    thus ?thesis ..
  next
    case (Load i)
    from Load app obtain y where
       y:  "i < size LT" "LT!i = OK y" by clarsimp
    from Load appi obtain y' where
       y': "i < size LT'" "LT'!i = OK y'" by clarsimp

    from less have "P  LT [≤] LT'" by simp
    with y y' have "P  y  y'" by (auto dest: list_all2_nthD)    
    with Load less y y' app appi
    show ?thesis by auto
  next
    case Store with less app appi
    show ?thesis by (auto simp add: list_all2_update_cong) 
  next
    case (Invoke M n) 
    with appi have n: "n < size ST'" by simp
    from less have [simp]: "size ST = size ST'" 
      by (auto dest: list_all2_lengthD)

    from Invoke succs have ST: "ST!n  NT" and ST': "ST'!n  NT"
      by (auto split: if_split_asm)
    
    from ST' appi Invoke obtain D Ts T m C' where
      D:   "ST' ! n = Class D" and
      D_M: "P  D sees M: TsT = m in C'"
      by auto

    from n D less have "P  ST!n  ST'!n" 
      by (fastforce dest: list_all2_nthD2)
    with D ST obtain D' where
      D': "ST ! n = Class D'" and DsubC: "P  D' * D"
      by (auto simp: widen_Class)
      
    from wf D_M DsubC obtain Ts' T' m' C'' where
      D'_M: "P  D' sees M: Ts'T' = m' in C''" and
      Ts': "P  T'  T"
      by (blast dest: sees_method_mono) 

    with Invoke n D D' D_M less 
    show ?thesis by (auto intro: list_all2_dropI)
  qed auto
qed
(*>*)

end

Theory BVSpec

(*  Title:      HOL/MicroJava/BV/BVSpec.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen

*)

section ‹The Bytecode Verifier \label{sec:BVSpec}›

theory BVSpec
imports Effect
begin

text ‹
  This theory contains a specification of the BV. The specification
  describes correct typings of method bodies; it corresponds 
  to type \emph{checking}.
›


definition
  ― ‹The method type only contains declared classes:›
  check_types :: "'m prog  nat  nat  tyi' err list  bool"
where 
  "check_types P mxs mxl τs  set τs  states P mxs mxl"

  ― ‹An instruction is welltyped if it is applicable and its effect›
  ― ‹is compatible with the type at all successor instructions:›
definition
  wt_instr :: "['m prog,ty,nat,pc,ex_table,instr,pc,tym]  bool"
  ("_,_,_,_,_  _,_ :: _" [60,0,0,0,0,0,0,61] 60)
where
  "P,T,mxs,mpc,xt  i,pc :: τs 
  app i P mxs T pc mpc xt (τs!pc)  
  ((pc',τ')  set (eff i P pc xt (τs!pc)). P  τ' ≤' τs!pc')"

  ― ‹The type at @{text "pc=0"} conforms to the method calling convention:›
definition wt_start :: "['m prog,cname,ty list,nat,tym]  bool"
where
  "wt_start P C Ts mxl0 τs 
  P  Some ([],OK (Class C)#map OK Ts@replicate mxl0 Err) ≤' τs!0"

  ― ‹A method is welltyped if the body is not empty,›
  ― ‹if the method type covers all instructions and mentions›
  ― ‹declared classes only, if the method calling convention is respected, and›
  ― ‹if all instructions are welltyped.›
definition wt_method :: "['m prog,cname,ty list,ty,nat,nat,instr list,
                 ex_table,tym]  bool"
where
  "wt_method P C Ts Tr mxs mxl0 is xt τs 
  0 < size is  size τs = size is 
  check_types P mxs (1+size Ts+mxl0) (map OK τs) 
  wt_start P C Ts mxl0 τs 
  (pc < size is. P,Tr,mxs,size is,xt  is!pc,pc :: τs)"

  ― ‹A program is welltyped if it is wellformed and all methods are welltyped›
definition  wf_jvm_prog_phi :: "tyP  jvm_prog  bool" ("wf'_jvm'_prog⇘_")
where
  "wf_jvm_progΦ 
    wf_prog (λP C (M,Ts,Tr,(mxs,mxl0,is,xt)). 
      wt_method P C Ts Tr mxs mxl0 is xt (Φ C M))"

definition wf_jvm_prog :: "jvm_prog  bool"
where
  "wf_jvm_prog P  Φ. wf_jvm_progΦ P"

lemma wt_jvm_progD:
  "wf_jvm_progΦ P  wt. wf_prog wt P"
(*<*) by (unfold wf_jvm_prog_phi_def, blast) (*>*)

lemma wt_jvm_prog_impl_wt_instr:
  " wf_jvm_progΦ P; 
      P  C sees M:Ts  T = (mxs,mxl0,ins,xt) in C; pc < size ins  
   P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def)
  done
(*>*)

lemma wt_jvm_prog_impl_wt_start:
  " wf_jvm_progΦ P; 
     P  C sees M:Ts  T = (mxs,mxl0,ins,xt) in C   
  0 < size ins  wt_start P C Ts mxl0 (Φ C M)"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def)
  done
(*>*)

end

Theory TF_JVM

(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section ‹The Typing Framework for the JVM \label{sec:JVM}›

theory TF_JVM
imports "../DFA/Typing_Framework_err" EffectMono BVSpec
begin

definition exec :: "jvm_prog  nat  ty  ex_table  instr list  tyi' err step_type"
where 
  "exec G maxs rT et bs 
  err_step (size bs) (λpc. app (bs!pc) G maxs rT pc (size bs) et) 
                     (λpc. eff (bs!pc) G pc et)"

locale JVM_sl =
  fixes P :: jvm_prog and mxs and mxl0
  fixes Ts :: "ty list" and "is" and xt and Tr

  fixes mxl and A and r and f and app and eff and step
  defines [simp]: "mxl  1+size Ts+mxl0"
  defines [simp]: "A    states P mxs mxl"
  defines [simp]: "r    JVM_SemiType.le P mxs mxl"
  defines [simp]: "f    JVM_SemiType.sup P mxs mxl"

  defines [simp]: "app  λpc. Effect.app (is!pc) P mxs Tr pc (size is) xt"
  defines [simp]: "eff  λpc. Effect.eff (is!pc) P pc xt"
  defines [simp]: "step  err_step (size is) app eff"


locale start_context = JVM_sl +
  fixes p and C
  assumes wf: "wf_prog p P"
  assumes C:  "is_class P C"
  assumes Ts: "set Ts  types P"

  fixes first :: tyi' and start
  defines [simp]: 
  "first  Some ([],OK (Class C) # map OK Ts @ replicate mxl0 Err)"
  defines [simp]:
  "start  OK first # replicate (size is - 1) (OK None)"



subsection ‹Connecting JVM and Framework›


lemma (in JVM_sl) step_def_exec: "step  exec P mxs Tr xt is" 
  by (simp add: exec_def)  

lemma special_ex_swap_lemma [iff]: 
  "(? X. (? n. X = A n & P n) & Q X) = (? n. Q(A n) & P n)"
  by blast

lemma ex_in_list [iff]:
  "(n. ST  list n A  n  mxs) = (set ST  A  size ST  mxs)"
  by (unfold list_def) auto

lemma singleton_list: 
  "(n. [Class C]  list n (types P)  n  mxs) = (is_class P C  0 < mxs)"
  by auto

lemma set_drop_subset:
  "set xs  A  set (drop n xs)  A"
  by (auto dest: in_set_dropD)

lemma Suc_minus_minus_le:
  "n < mxs  Suc (n - (n - b))  mxs"
  by arith

lemma in_listE:
  " xs  list n A; size xs = n; set xs  A  P   P"
  by (unfold list_def) blast

declare is_relevant_entry_def [simp]
declare set_drop_subset [simp]

theorem (in start_context) exec_pres_type:
  "pres_type step (size is) A"
(*<*)
  apply (insert wf)
  apply simp
  apply (unfold JVM_states_unfold)
  apply (rule pres_type_lift)
  apply clarify
  apply (rename_tac s pc pc' s')
  apply (case_tac s)
   apply simp
   apply (drule effNone)
   apply simp  
  apply (simp add: Effect.app_def xcpt_app_def Effect.eff_def  
                   xcpt_eff_def norm_eff_def relevant_entries_def)
  apply (case_tac "is!pc")

  ― ‹Load›
  apply clarsimp
  apply (frule listE_nth_in, assumption)
  apply fastforce

  ― ‹Store›
  apply fastforce

  ― ‹Push›
  apply (fastforce simp add: typeof_lit_is_type)

  ― ‹New›
  apply fastforce

  ― ‹Getfield›
  apply (fastforce dest: sees_field_is_type)

  ― ‹Putfield›
  apply fastforce

  ― ‹Checkcast›
  apply fastforce

  defer 
  
  ― ‹Return›
  apply fastforce

  ― ‹Pop›
  apply fastforce

  ― ‹IAdd›
  apply fastforce
  
  ― ‹Goto›
  apply fastforce

  ― ‹CmpEq›
  apply fastforce

  ― ‹IfFalse›
  apply fastforce

  ― ‹Throw›
  apply fastforce

  ― ‹Invoke›
  apply (clarsimp split!: if_splits)
   apply fastforce
  apply (erule disjE)
   prefer 2
   apply fastforce
  apply clarsimp
  apply (rule conjI)
   apply (drule (1) sees_wf_mdecl)
   apply (clarsimp simp add: wf_mdecl_def)
  apply arith
  done
(*>*)

declare is_relevant_entry_def [simp del]
declare set_drop_subset [simp del]

lemma lesubstep_type_simple:
  "xs [⊑Product.le (=) r] ys  set xs {⊑r} set ys"
(*<*)
  apply (unfold lesubstep_type_def)
  apply clarify
  apply (simp add: set_conv_nth)
  apply clarify
  apply (drule le_listD, assumption)
  apply (clarsimp simp add: lesub_def Product.le_def)
  apply (rule exI)
  apply (rule conjI)
   apply (rule exI)
   apply (rule conjI)
    apply (rule sym)
    apply assumption
   apply assumption
  apply assumption
  done
(*>*)

declare is_relevant_entry_def [simp del]


lemma conjI2: " A; A  B   A  B" by blast
  
lemma (in JVM_sl) eff_mono:
  "wf_prog p P; pc < length is; ssup_state_opt P t; app pc t
   set (eff pc s) {⊑sup_state_opt P} set (eff pc t)"
(*<*)
  apply simp
  apply (unfold Effect.eff_def)  
  apply (cases t)
   apply (simp add: lesub_def)
  apply (rename_tac a)
  apply (cases s)
   apply simp
  apply (rename_tac b)
  apply simp
  apply (rule lesubstep_union)
   prefer 2
   apply (rule lesubstep_type_simple)
   apply (simp add: xcpt_eff_def)
   apply (rule le_listI)
    apply (simp add: split_beta)
   apply (simp add: split_beta)
   apply (simp add: lesub_def fun_of_def)
   apply (case_tac a)
   apply (case_tac b)
   apply simp   
   apply (subgoal_tac "size ab = size aa")
     prefer 2
     apply (clarsimp simp add: list_all2_lengthD)
   apply simp
  apply (clarsimp simp add: norm_eff_def lesubstep_type_def lesub_def iff del: sup_state_conv)
  apply (rule exI)
  apply (rule conjI2)
   apply (rule imageI)
   apply (clarsimp simp add: Effect.app_def iff del: sup_state_conv)
   apply (drule (2) succs_mono)
   apply blast
  apply simp
  apply (erule effi_mono)
     apply simp
    apply assumption   
   apply clarsimp
  apply clarsimp  
  done
(*>*)

lemma (in JVM_sl) bounded_step: "bounded step (size is)"
(*<*)
  apply simp
  apply (unfold bounded_def err_step_def Effect.app_def Effect.eff_def)
  apply (auto simp add: error_def map_snd_def split: err.splits option.splits)
  done
(*>*)

theorem (in JVM_sl) step_mono:
  "wf_prog wf_mb P  mono r step (size is) A"
(*<*)
  apply (simp add: JVM_le_Err_conv)  
  apply (insert bounded_step)
  apply (unfold JVM_states_unfold)
  apply (rule mono_lift)
     apply blast
    apply (unfold app_mono_def lesub_def)
    apply clarsimp
    apply (erule (2) app_mono)
   apply simp
  apply clarify
  apply (drule eff_mono)
  apply (auto simp add: lesub_def)
  done
(*>*)


lemma (in start_context) first_in_A [iff]: "OK first  A"
  using Ts C by (force intro!: list_appendI simp add: JVM_states_unfold)


lemma (in JVM_sl) wt_method_def2:
  "wt_method P C' Ts Tr mxs mxl0 is xt τs =
  (is  []  
   size τs = size is 
   OK ` set τs  states P mxs mxl 
   wt_start P C' Ts mxl0 τs  
   wt_app_eff (sup_state_opt P) app eff τs)"
(*<*)
  apply (unfold wt_method_def wt_app_eff_def wt_instr_def lesub_def check_types_def)
  apply auto
  done
(*>*)


end

Theory BVExec

(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section ‹Kildall for the JVM \label{sec:JVM}›

theory BVExec
imports "../DFA/Abstract_BV" TF_JVM
begin

definition kiljvm :: "jvm_prog  nat  nat  ty  
             instr list  ex_table  tyi' err list  tyi' err list"
where
  "kiljvm P mxs mxl Tr is xt 
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl) 
          (exec P mxs Tr xt is)"

definition wt_kildall :: "jvm_prog  cname  ty list  ty  nat  nat  
                 instr list  ex_table  bool"
where
  "wt_kildall P C' Ts Tr mxs mxl0 is xt 
   0 < size is  
   (let first  = Some ([],[OK (Class C')]@(map OK Ts)@(replicate mxl0 Err));
        start  = OK first#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs (1+size Ts+mxl0) Tr is xt  start
    in n < size is. result!n  Err)"

definition wf_jvm_progk :: "jvm_prog  bool"
where
  "wf_jvm_progk P 
  wf_prog (λP C' (M,Ts,Tr,(mxs,mxl0,is,xt)). wt_kildall P C' Ts Tr mxs mxl0 is xt) P"


theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl Tr is xt)"
(*<*)
  apply (insert wf)
  apply (unfold kiljvm_def)
  apply (fold r_def f_def step_def_exec)
  apply (rule is_bcv_kildall)
       apply simp apply (rule Semilat.intro)
       apply (fold sl_def2)
       apply (erule semilat_JVM)
      apply simp
      apply blast
     apply (simp add: JVM_le_unfold)
    apply (rule exec_pres_type)
   apply (rule bounded_step)
  apply (erule step_mono)
  done
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x)  {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x  set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y)  {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is  start  list (size is) A"
  using Ts C
(*<*)
  apply (simp add: JVM_states_unfold) 
  apply (force intro!: listI list_appendI dest!: in_set_replicate)
  done   
(*>*)


theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C Ts Tr mxs mxl0 is xt"
  shows "τs. wt_method P C Ts Tr mxs mxl0 is xt τs"
(*<*)
proof -
  from wtk obtain res where    
    result:   "res = kiljvm P mxs mxl Tr is xt start" and
    success:  "n < size is. res!n  Err" and
    instrs:   "0 < size is" 
    by (unfold wt_kildall_def) simp
      
  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl Tr is xt)"
    by (rule is_bcv_kiljvm)
    
  from instrs have "start  list (size is) A" ..
  with bcv success result have 
    "tslist (size is) A. start [⊑⇩r] ts  wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain τs' where
    in_A: "τs'  list (size is) A" and
    s:    "start [⊑⇩r] τs'" and
    w:    "wt_step r Err step τs'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step τs'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size τs' = size is" by simp  
  moreover {
    from in_A  have "check_types P mxs mxl τs'" by (simp add: check_types_def)
    also from w have "x  set τs'. x  Err" 
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val τs') = τs'" 
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val τs'))" .
  } 
  moreover {  
    from s have "start!0 ⊑⇩r τs'!0" by (rule le_listD) simp
    moreover
    from instrs w l 
    have "τs'!0  Err" by (unfold wt_step_def) simp
    then obtain τs0 where "τs'!0 = OK τs0" by auto
    ultimately
    have "wt_start P C Ts mxl0 (map ok_val τs')" using l instrs
      by (unfold wt_start_def) 
         (simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover 
  from in_A have "set τs'  A" by simp  
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val τs')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C Ts Tr mxs mxl0 is xt (map ok_val τs')"
    using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)


theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C Ts Tr mxs mxl0 is xt τs"
  shows "wt_kildall P C Ts Tr mxs mxl0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length τs = length is" and 
    ck_type:  "check_types P mxs mxl (map OK τs)" and
    wt_start: "wt_start P C Ts mxl0 τs" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff τs"
    by (simp add: wt_method_def2 check_types_def)

  from ck_type
  have in_A: "set (map OK τs)  A" 
    by (simp add: check_types_def)  
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size τs) app eff) (map OK τs)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK τs)" 
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl Tr is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start  list (size is) A" ..
  moreover
  let ?τs = "map OK τs"  
  have less_τs: "start [⊑⇩r] ?τs"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK τs)" by simp
  next
    fix n
    from wt_start have "P  ok_val (start!0) ≤' τs!0" 
      by (simp add: wt_start_def)
    moreover from instrs length have "0 < length τs" by simp
    ultimately have "start!0 ⊑⇩r ?τs!0" 
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None ⊑⇩r ?τs!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def 
                 split: err.splits)
      hence "n = Suc n'; n < size start  start!n ⊑⇩r ?τs!n" by simp
    }
    ultimately
    show "n < size start  start!n ⊑⇩r ?τs!n" by (cases n, blast+)   
  qed
  moreover
  from ck_type length
  have "?τs  list (size is) A"
    by (auto intro!: listI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?τs" 
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "p. p < size is  kiljvm P  mxs mxl Tr is xt start ! p  Err" 
    by (unfold is_bcv_def) blast
  with instrs 
  show "wt_kildall P C Ts Tr mxs mxl0 is xt" by (unfold wt_kildall_def) simp
qed
(*>*)


theorem jvm_kildall_correct:
  "wf_jvm_progk P = wf_jvm_prog P"
(*<*)
proof 
  let  = "λC M. let (C,Ts,Tr,(mxs,mxl0,is,xt)) = method P C M in 
              SOME τs. wt_method P C Ts Tr mxs mxl0 is xt τs"

  ― ‹soundness›
  assume wt: "wf_jvm_progk P"
  hence "wf_jvm_prog P"
    apply (unfold wf_jvm_prog_phi_def wf_jvm_progk_def)    
    apply (erule wf_prog_lift)
    apply (auto dest!: start_context.wt_kil_correct [OF start_context.intro] 
                intro: someI)
    apply (erule sees_method_is_class)
    done
  thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
next
  ― ‹completeness›
  assume wt: "wf_jvm_prog P"
  thus "wf_jvm_progk P"
    apply (unfold wf_jvm_prog_def wf_jvm_prog_phi_def wf_jvm_progk_def)
    apply (clarify)
    apply (erule wf_prog_lift)
    apply (auto intro!: start_context.wt_kil_complete start_context.intro)
    apply (erule sees_method_is_class)
    done
qed
(*>*)

end

Theory LBVJVM

(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section ‹LBV for the JVM \label{sec:JVM}›

theory LBVJVM
imports "../DFA/Abstract_BV" TF_JVM
begin

type_synonym prog_cert = "cname  mname  tyi' err list"

definition check_cert :: "jvm_prog  nat  nat  nat  tyi' err list  bool"
where
  "check_cert P mxs mxl n cert  check_types P mxs mxl cert  size cert = n+1 
                                 (i<n. cert!i  Err)  cert!n = OK None"

definition lbvjvm :: "jvm_prog  nat  nat  ty  ex_table  
             tyi' err list  instr list  tyi' err  tyi' err"
where
  "lbvjvm P mxs maxr Tr et cert bs 
  wtl_inst_list bs cert (JVM_SemiType.sup P mxs maxr) (JVM_SemiType.le P mxs maxr) Err (OK None) (exec P mxs Tr et bs) 0"

definition wt_lbv :: "jvm_prog  cname  ty list  ty  nat  nat  
             ex_table  tyi' err list  instr list  bool"
where
  "wt_lbv P C Ts Tr mxs mxl0 et cert ins 
   check_cert P mxs (1+size Ts+mxl0) (size ins) cert 
   0 < size ins  
   (let start  = Some ([],(OK (Class C))#((map OK Ts))@(replicate mxl0 Err));
        result = lbvjvm P mxs (1+size Ts+mxl0) Tr et cert ins (OK start)
    in result  Err)"

definition wt_jvm_prog_lbv :: "jvm_prog  prog_cert  bool"
where
  "wt_jvm_prog_lbv P cert 
  wf_prog (λP C (mn,Ts,Tr,(mxs,mxl0,b,et)). wt_lbv P C Ts Tr mxs mxl0 et (cert C mn) b) P"

definition mk_cert :: "jvm_prog  nat  ty  ex_table  instr list 
               tym  tyi' err list"
where
  "mk_cert P mxs Tr et bs phi  make_cert (exec P mxs Tr et bs) (map OK phi) (OK None)"

definition prg_cert :: "jvm_prog  tyP  prog_cert"
where
  "prg_cert P phi C mn  let (C,Ts,Tr,(mxs,mxl0,ins,et)) = method P C mn
                         in  mk_cert P mxs Tr et ins (phi C mn)"
   
lemma check_certD [intro?]:
  "check_cert P mxs mxl n cert  cert_ok cert n Err (OK None) (states P mxs mxl)"
  by (unfold cert_ok_def check_cert_def check_types_def) auto


lemma (in start_context) wt_lbv_wt_step:
  assumes lbv: "wt_lbv P C Ts Tr mxs mxl0 xt cert is"
  shows "τs  list (size is) A. wt_step r Err step τs  OK first ⊑⇩r τs!0"
(*<*)
proof -
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err  A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)" 
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None  A" by (simp add: JVM_states_unfold)
  moreover note bounded_step
  moreover from lbv have "cert_ok cert (size is) Err (OK None) A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover note exec_pres_type
  moreover
  from lbv 
  have "wtl_inst_list is cert f r Err (OK None) step 0 (OK first)  Err"
    by (simp add: wt_lbv_def lbvjvm_def step_def_exec [symmetric])    
  moreover note first_in_A
  moreover from lbv have "0 < size is" by (simp add: wt_lbv_def)
  ultimately show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed
(*>*)


lemma (in start_context) wt_lbv_wt_method:
  assumes lbv: "wt_lbv P C Ts Tr mxs mxl0 xt cert is"  
  shows "τs. wt_method P C Ts Tr mxs mxl0 is xt τs"
(*<*)
proof -
  from lbv have l: "is  []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C Ts obtain τs where 
    list:  "τs  list (size is) A" and
    step:  "wt_step r Err step τs" and    
    start: "OK first ⊑⇩r τs!0" 
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "size τs = size is" by simp
  have "size (map ok_val τs) = size is" by simp  
  moreover from l have 0: "0 < size τs" by simp
  with step obtain τs0 where "τs!0 = OK τs0"
    by (unfold wt_step_def) blast
  with start 0 have "wt_start P C Ts mxl0 (map ok_val τs)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def Err.le_def)    
  moreover {
    from list have "check_types P mxs mxl τs" by (simp add: check_types_def)
    also from step  have "x  set τs. x  Err" 
      by (auto simp add: all_set_conv_all_nth wt_step_def)    
    hence [symmetric]: "map OK (map ok_val τs) = τs"
      by (auto intro!: map_idI)
    finally have "check_types P mxs mxl (map OK (map ok_val τs))" .
  }
  moreover {  
    note bounded_step
    moreover from list have "set τs  A" by simp
    moreover from step have "wt_err_step (sup_state_opt P) step τs"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately have "wt_app_eff (sup_state_opt P) app eff (map ok_val τs)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def states_def)
  }    
  ultimately have "wt_method P C Ts Tr mxs mxl0 is xt (map ok_val τs)"
    by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis ..
qed
(*>*)

  
lemma (in start_context) wt_method_wt_lbv:
  assumes wt: "wt_method P C Ts Tr mxs mxl0 is xt τs" 
  defines [simp]: "cert  mk_cert P mxs Tr xt is τs"
  
  shows "wt_lbv P C Ts Tr mxs mxl0 xt cert is" 
(*<*)
proof -
  let ?τs  = "map OK τs"
  let ?cert = "make_cert step ?τs (OK None)"

  from wt obtain 
    0:        "0 < size is" and
    size:     "size is = size ?τs" and
    ck_types: "check_types P mxs mxl ?τs" and
    wt_start: "wt_start P C Ts mxl0 τs" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff τs"
    by (force simp add: wt_method_def2 check_types_def) 
  
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err  A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)" 
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None  A" by (simp add: JVM_states_unfold)
  moreover from wf have "mono r step (size is) A" by (rule step_mono)
  hence "mono r step (size ?τs) A" by (simp add: size)
  moreover from exec_pres_type 
  have "pres_type step (size ?τs) A" by (simp add: size) 
  moreover
  from ck_types have τs_in_A: "set ?τs  A" by (simp add: check_types_def)
  hence "pc. pc < size ?τs  ?τs!pc  A  ?τs!pc  Err" by auto
  moreover from bounded_step 
  have "bounded step (size ?τs)" by (simp add: size)
  moreover have "OK None  Err" by simp
  moreover from bounded_step size τs_in_A app_eff
  have "wt_err_step (sup_state_opt P) step ?τs"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def states_def)    
  hence "wt_step r Err step ?τs"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  from 0 size have "0 < size τs" by auto
  hence "?τs!0 = OK (τs!0)" by simp
  with wt_start have "OK first ⊑⇩r ?τs!0"
    by (clarsimp simp add: wt_start_def lesub_def Err.le_def JVM_le_Err_conv)
  moreover note first_in_A
  moreover have "OK first  Err" by simp
  moreover note size 
  ultimately
  have "wtl_inst_list is ?cert f r Err (OK None) step 0 (OK first)  Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover from 0 size have "τs  []" by auto
  moreover from ck_types have "check_types P mxs mxl ?cert"
    apply (auto simp add: make_cert_def check_types_def JVM_states_unfold)
    apply (subst Ok_in_err [symmetric])
    apply (drule nth_mem)
    apply auto
    done
  moreover note 0 size
  ultimately show ?thesis 
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def step_def_exec [symmetric]
                  check_cert_def make_cert_def nth_append)
qed  
(*>*)


theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv P Cert  wf_jvm_prog P"
(*<*)
proof -  
  let  = "λC mn. let (C,Ts,Tr,(mxs,mxl0,is,xt)) = method P C mn in 
              SOME τs. wt_method P C Ts Tr mxs mxl0 is xt τs"
    
  assume wt: "wt_jvm_prog_lbv P Cert"
  hence "wf_jvm_prog P"
    apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def) 
    apply (erule wf_prog_lift)
    apply (auto dest!: start_context.wt_lbv_wt_method [OF start_context.intro] 
                intro: someI)
    apply (erule sees_method_is_class)
    done
  thus ?thesis by (unfold wf_jvm_prog_def) blast
qed
(*>*)

theorem jvm_lbv_complete:
  assumes wt: "wf_jvm_progΦ P" 
  shows "wt_jvm_prog_lbv P (prg_cert P Φ)"
(*<*)
  using wt
  apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
  apply (erule wf_prog_lift)
  apply (auto simp add: prg_cert_def 
              intro!: start_context.wt_method_wt_lbv start_context.intro)
  apply (erule sees_method_is_class)                                     
  done
(*>*)

end  

Theory BVConform

(*  Title:      HOL/MicroJava/BV/Correct.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen

The invariant for the type safety proof.
*)

section ‹BV Type Safety Invariant›

theory BVConform
imports BVSpec "../JVM/JVMExec" "../Common/Conform"
begin


definition confT :: "'c prog  heap  val  ty err  bool" 
    ("_,_  _ :≤ _" [51,51,51,51] 50)
where
  "P,h  v :≤ E  case E of Err  True | OK T  P,h  v :≤ T"

notation (ASCII)
  confT  ("_,_ |- _ :<=T _" [51,51,51,51] 50)

abbreviation
  confTs :: "'c prog  heap  val list  tyl  bool" 
      ("_,_  _ [:≤] _" [51,51,51,51] 50) where
  "P,h  vs [:≤] Ts  list_all2 (confT P h) vs Ts"

notation (ASCII)
  confTs  ("_,_ |- _ [:<=T] _" [51,51,51,51] 50)

definition conf_f  :: "jvm_prog  heap  tyi  bytecode  frame  bool"
where
  "conf_f P h  λ(ST,LT) is (stk,loc,C,M,pc).
  P,h  stk [:≤] ST  P,h  loc [:≤] LT  pc < size is"

lemma conf_f_def2:
  "conf_f P h (ST,LT) is (stk,loc,C,M,pc) 
  P,h  stk [:≤] ST  P,h  loc [:≤] LT  pc < size is"
  by (simp add: conf_f_def)


primrec conf_fs :: "[jvm_prog,heap,tyP,mname,nat,ty,frame list]  bool"
where
  "conf_fs P h Φ M0 n0 T0 [] = True"
| "conf_fs P h Φ M0 n0 T0 (f#frs) =
  (let (stk,loc,C,M,pc) = f in
  (ST LT Ts T mxs mxl0 is xt.
    Φ C M ! pc = Some (ST,LT)  
    (P  C sees M:Ts  T = (mxs,mxl0,is,xt) in C) 
    (D Ts' T' m D'.  
       is!pc = (Invoke M0 n0)  ST!n0 = Class D 
       P  D sees M0:Ts'  T' = m in D'  P  T0  T') 
    conf_f P h (ST, LT) is f  conf_fs P h Φ M (size Ts) T frs))"


definition correct_state :: "[jvm_prog,tyP,jvm_state]  bool"  ("_,_  _ "  [61,0,0] 61)
where
  "correct_state P Φ  λ(xp,h,frs).
  case xp of
     None  (case frs of
             []  True
             | (f#fs)  P h  
             (let (stk,loc,C,M,pc) = f
              in Ts T mxs mxl0 is xt τ.
                    (P  C sees M:TsT = (mxs,mxl0,is,xt) in C) 
                    Φ C M ! pc = Some τ 
                    conf_f P h τ is f  conf_fs P h Φ M (size Ts) T fs))
  | Some x  frs = []" 

notation
  correct_state  ("_,_ |- _ [ok]"  [61,0,0] 61)


subsection ‹Values and ⊤›

lemma confT_Err [iff]: "P,h  x :≤ Err" 
  by (simp add: confT_def)

lemma confT_OK [iff]:  "P,h  x :≤ OK T = (P,h  x :≤ T)"
  by (simp add: confT_def)

lemma confT_cases:
  "P,h  x :≤ X = (X = Err  (T. X = OK T  P,h  x :≤ T))"
  by (cases X) auto

lemma confT_hext [intro?, trans]:
  " P,h  x :≤ T; h  h'   P,h'  x :≤ T"
  by (cases T) (blast intro: conf_hext)+

lemma confT_widen [intro?, trans]:
  " P,h  x :≤ T; P  T  T'   P,h  x :≤ T'"
  by (cases T', auto intro: conf_widen)


subsection ‹Stack and Registers›

lemmas confTs_Cons1 [iff] = list_all2_Cons1 [of "confT P h"] for P h

lemma confTs_confT_sup:
  " P,h  loc [:≤] LT; n < size LT; LT!n = OK T; P  T  T'  
   P,h  (loc!n) :≤ T'"
(*<*)
  apply (frule list_all2_lengthD)
  apply (drule list_all2_nthD, simp)
  apply simp
  apply (erule conf_widen, assumption+)
  done
(*>*)

lemma confTs_hext [intro?]:
  "P,h  loc [:≤] LT  h  h'  P,h'  loc [:≤] LT"
  by (fast elim: list_all2_mono confT_hext)    

lemma confTs_widen [intro?, trans]:
  "P,h  loc [:≤] LT  P  LT [≤] LT'  P,h  loc [:≤] LT'"
  by (rule list_all2_trans, rule confT_widen)

lemma confTs_map [iff]:
  "vs. (P,h  vs [:≤] map OK Ts) = (P,h  vs [:≤] Ts)"
  by (induct Ts) (auto simp add: list_all2_Cons2)

lemma reg_widen_Err [iff]:
  "LT. (P  replicate n Err [≤] LT) = (LT = replicate n Err)"
  by (induct n) (auto simp add: list_all2_Cons1)
    
lemma confTs_Err [iff]:
  "P,h  replicate n v [:≤] replicate n Err"
  by (induct n) auto

  
subsection ‹correct-frames›

lemmas [simp del] = fun_upd_apply

lemma conf_fs_hext:
  "M n Tr. 
   conf_fs P h Φ M n Tr frs; h  h'   conf_fs P h' Φ M n Tr frs"
(*<*)
apply (induct frs)
 apply simp
apply clarify
apply (simp (no_asm_use))
apply clarify
apply (unfold conf_f_def)
apply (simp (no_asm_use))
apply clarify
apply (fast elim!: confs_hext confTs_hext)
done
(*>*)

end

Theory BVSpecTypeSafe

(*  Title:      HOL/MicroJava/BV/BVSpecTypeSafe.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section ‹BV Type Safety Proof \label{sec:BVSpecTypeSafe}›

theory BVSpecTypeSafe
imports BVConform
begin

text ‹
  This theory contains proof that the specification of the bytecode
  verifier only admits type safe programs.  
›

subsection ‹Preliminaries›

text ‹
  Simp and intro setup for the type safety proof:
›
lemmas defs1 = correct_state_def conf_f_def wt_instr_def eff_def norm_eff_def app_def xcpt_app_def

lemmas widen_rules [intro] = conf_widen confT_widen confs_widens confTs_widen

  
subsection ‹Exception Handling›


text ‹
  For the Invoke› instruction the BV has checked all handlers
  that guard the current pc›.
›
lemma Invoke_handlers:
  "match_ex_table P C pc xt = Some (pc',d')  
  (f,t,D,h,d)  set (relevant_entries P (Invoke n M) pc xt). 
   P  C * D  pc  {f..<t}  pc' = h  d' = d"
  by (induct xt) (auto simp add: relevant_entries_def matches_ex_entry_def 
                                 is_relevant_entry_def split: if_split_asm)


text ‹
  We can prove separately that the recursive search for exception
  handlers (find_handler›) in the frame stack results in 
  a conforming state (if there was no matching exception handler 
  in the current frame). We require that the exception is a valid
  heap address, and that the state before the exception occurred
  conforms. 
› term find_handler
lemma uncaught_xcpt_correct:
  assumes wt: "wf_jvm_progΦ P"
  assumes h:  "h xcp = Some obj"
  shows "f. P,Φ  (None, h, f#frs)  P,Φ  (find_handler P xcp h frs) " 
  (is "f. ?correct (None, h, f#frs)  ?correct (?find frs)")
(*<*)
proof (induct frs) 
  ― ‹the base
 case is trivial as it should be›
  show "?correct (?find [])" by (simp add: correct_state_def)
next
  ― ‹we will need both forms @{text wf_jvm_prog} and @{text wf_prog} later›
  from wt obtain mb where wf: "wf_prog mb P" by (simp add: wf_jvm_prog_phi_def)

  ― ‹the assumption for the cons case:›
  fix f f' frs' assume cr: "?correct (None, h, f#f'#frs')" 

  ― ‹the induction hypothesis:›
  assume IH: "f. ?correct (None, h, f#frs')  ?correct (?find frs')" 

  from cr have cr': "?correct (None, h, f'#frs')"
    by (fastforce simp add: correct_state_def)
    
  obtain stk loc C M pc where [simp]: "f' = (stk,loc,C,M,pc)" by (cases f')

  from cr obtain Ts T mxs mxl0 ins xt where
    meth: "P  C sees M:Ts  T = (mxs,mxl0,ins,xt) in C"
    by (simp add: correct_state_def, blast)

  hence [simp]: "ex_table_of P C M = xt" by simp

  show "?correct (?find (f'#frs'))" 
  proof (cases "match_ex_table P (cname_of h xcp) pc xt")
    case None with cr' IH [of f'] show ?thesis by fastforce
  next
    fix pc_d
    assume "match_ex_table P (cname_of h xcp) pc xt = Some pc_d"
    then obtain pc' d' where 
      match: "match_ex_table P (cname_of h xcp) pc xt = Some (pc',d')"
      (is "?match (cname_of h xcp) = _")
      by (cases pc_d) auto 

    from wt meth cr' [simplified]
    have wti: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M" 
      by (fastforce simp add: correct_state_def conf_f_def
                   dest: sees_method_fun
                   elim!: wt_jvm_prog_impl_wt_instr)
    from cr meth
    obtain n M' ST LT where
      ins: "ins!pc = Invoke n M'" (is "_ = ?i") and
      Φ: "Φ C M ! pc = Some (ST, LT)"
      by (fastforce dest: sees_method_fun simp add: correct_state_def)
    
    from ins match obtain f t D where
      rel: "(f,t,D,pc',d')  set (relevant_entries P (ins!pc) pc xt)" and
      D: "P  cname_of h xcp * D"
      by (fastforce dest: Invoke_handlers)
    
    from rel have 
      "(pc', Some (Class D # drop (size ST - d') ST, LT))  set (xcpt_eff (ins!pc) P pc (ST,LT) xt)"
      (is "(_, Some (?ST',_))  _")
      by (force simp add: xcpt_eff_def image_def)      
    with wti Φ obtain 
      pc: "pc' < size ins" and
      "P  Some (?ST', LT) ≤' Φ C M ! pc'"
      by (clarsimp simp add: defs1) blast
    then obtain ST' LT' where
      Φ': "Φ C M ! pc' = Some (ST',LT')" and
      less: "P  (?ST', LT) i (ST',LT')"
      by (auto simp add: sup_state_opt_any_Some)   
    
    from cr' Φ meth have "conf_f P h (ST, LT) ins f'"
      by (unfold correct_state_def) (fastforce dest: sees_method_fun)
    hence loc: "P,h  loc [:≤] LT" and 
          stk: "P,h  stk [:≤] ST" by (unfold conf_f_def) auto
    hence [simp]: "size stk = size ST" by (simp add: list_all2_lengthD)

    let ?f = "(Addr xcp # drop (length stk - d') stk, loc, C, M, pc')"
    have "conf_f P h (ST',LT') ins ?f" 
    proof -
      from wf less loc have "P,h  loc [:≤] LT'" by simp blast
      moreover from D h have "P,h  Addr xcp :≤ Class D" 
        by (simp add: conf_def obj_ty_def case_prod_unfold)
      with less stk
      have "P,h  Addr xcp # drop (length stk - d') stk  [:≤] ST'" 
        by (auto intro!: list_all2_dropI)
      ultimately show ?thesis using pc by (simp add: conf_f_def) 
    qed

    with cr' match Φ' meth pc
    show ?thesis by (unfold correct_state_def) (fastforce dest: sees_method_fun)
  qed
qed
(*>*)

text ‹
  The requirement of lemma uncaught_xcpt_correct› (that
  the exception is a valid reference on the heap) is always met
  for welltyped instructions and conformant states:
›
lemma exec_instr_xcpt_h:
  "  fst (exec_instr (ins!pc) P h stk vars Cl M pc frs) = Some xcp;
       P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M;
       P,Φ  (None, h, (stk,loc,C,M,pc)#frs) 
   obj. h xcp = Some obj" 
  (is " ?xcpt; ?wt; ?correct   ?thesis")
(*<*)
proof -
  note [simp] = split_beta
  note [split] = if_split_asm option.split_asm 
  
  assume wt: ?wt ?correct
  hence pre: "preallocated h" by (simp add: correct_state_def hconf_def)

  assume xcpt: ?xcpt with pre show ?thesis 
  proof (cases "ins!pc")
    case Throw with xcpt wt pre show ?thesis 
      by (clarsimp iff: list_all2_Cons2 simp add: defs1) 
         (auto dest: non_npD simp: is_refT_def elim: preallocatedE)
  qed (auto elim: preallocatedE)
qed
(*>*)

lemma conf_sys_xcpt:
  "preallocated h; C  sys_xcpts  P,h  Addr (addr_of_sys_xcpt C) :≤ Class C"
  by (auto elim: preallocatedE)

lemma match_ex_table_SomeD:
  "match_ex_table P C pc xt = Some (pc',d')  
  (f,t,D,h,d)  set xt. matches_ex_entry P C pc (f,t,D,h,d)  h = pc'  d=d'"
  by (induct xt) (auto split: if_split_asm)


text ‹
  Finally we can state that, whenever an exception occurs, the
  next state always conforms:
›
lemma xcpt_correct:
  fixes σ' :: jvm_state
  assumes wtp:  "wf_jvm_progΦ P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes xp:   "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = Some xcp"
  assumes s':   "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes correct: "P,Φ  (None, h, (stk,loc,C,M,pc)#frs)"
  shows "P,Φ  σ'"
(*<*)
proof -
  from wtp obtain wfmb where wf: "wf_prog wfmb P" 
    by (simp add: wf_jvm_prog_phi_def)                

  note conf_sys_xcpt [elim!]
  note xp' = meth s' xp

  note wtp
  moreover
  from xp wt correct
  obtain obj where h: "h xcp = Some obj" by (blast dest: exec_instr_xcpt_h)
  moreover note correct
  ultimately
  have "P,Φ  find_handler P xcp h frs " by (rule uncaught_xcpt_correct)
  with xp'
  have "match_ex_table P (cname_of h xcp) pc xt = None  ?thesis" 
    (is "?m (cname_of h xcp) = _  _" is "?match = _  _")
    by (simp add: split_beta)
  moreover
  { fix pc_d assume "?match = Some pc_d"
    then obtain pc' d' where some_handler: "?match = Some (pc',d')" 
      by (cases pc_d) auto
    
    from correct meth
    obtain ST LT where
      h_ok:  "P  h " and
      Φ_pc: "Φ C M ! pc = Some (ST, LT)" and
      frame:  "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
      frames: "conf_fs P h Φ M (size Ts) T frs"
      by (unfold correct_state_def) (fastforce dest: sees_method_fun)

    from h_ok have preh: "preallocated h" by (simp add: hconf_def)

    from frame obtain 
      stk: "P,h  stk [:≤] ST" and
      loc: "P,h  loc [:≤] LT" and
      pc:  "pc < size ins" 
      by (unfold conf_f_def) auto
    
    from stk have [simp]: "size stk = size ST" ..

    from wt Φ_pc have
      eff: "(pc', s')set (xcpt_eff (ins!pc) P pc (ST,LT) xt).
             pc' < size ins  P  s' ≤' Φ C M!pc'"
      by (auto simp add: defs1)     
    
    let ?stk' = "Addr xcp # drop (length stk - d') stk"
    let ?f = "(?stk', loc, C, M, pc')"
    from some_handler xp' 
    have σ': "σ' = (None, h, ?f#frs)"
      by (simp add: split_beta)

    from some_handler obtain f t D where
      xt: "(f,t,D,pc',d')  set xt" and
      "matches_ex_entry P (cname_of h xcp) pc (f,t,D,pc',d')"
      by (auto dest: match_ex_table_SomeD)

    hence match: "P  cname_of h xcp * D"  "pc  {f..<t}"
      by (auto simp: matches_ex_entry_def)

    from xp obtain
      "(f,t,D,pc',d')  set (relevant_entries P (ins!pc) pc xt)" and
      conf: "P,h  Addr xcp :≤ Class D"
    proof (cases "ins!pc")
      case Return
      with xp have False by (auto simp: split_beta split: if_split_asm)
      thus ?thesis ..
    next
      case New with xp
      have [simp]: "xcp = addr_of_sys_xcpt OutOfMemory" by simp
      with New match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Getfield with xp
      have [simp]: "xcp = addr_of_sys_xcpt NullPointer" 
        by (simp add: split_beta split: if_split_asm)
      with Getfield match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Putfield with xp
      have [simp]: "xcp = addr_of_sys_xcpt NullPointer" 
        by (simp add: split_beta split: if_split_asm)
      with Putfield match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Checkcast with xp
      have [simp]: "xcp = addr_of_sys_xcpt ClassCast" 
        by (simp add: split_beta split: if_split_asm)
      with Checkcast match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Invoke with xp match 
      have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      moreover
      from xp wt correct obtain obj where xcp: "h xcp = Some obj" 
        by (blast dest: exec_instr_xcpt_h)
      ultimately
      show ?thesis using xt match
        by (auto simp add: relevant_entries_def conf_def case_prod_unfold intro: that)
    next
      case Throw with xp match preh 
      have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      moreover
      from xp wt correct obtain obj where xcp: "h xcp = Some obj" 
        by (blast dest: exec_instr_xcpt_h)
      ultimately
      show ?thesis using xt match
        by (auto simp add: relevant_entries_def conf_def case_prod_unfold intro: that)
    qed auto

    with eff obtain ST' LT' where
      Φ_pc': "Φ C M ! pc' = Some (ST', LT')" and
      pc':   "pc' < size ins" and
      less:  "P  (Class D # drop (size ST - d') ST, LT) i (ST', LT')"
      by (fastforce simp add: xcpt_eff_def sup_state_opt_any_Some)

    with conf loc stk have "conf_f P h (ST',LT') ins ?f" 
      by (auto simp add: defs1 intro: list_all2_dropI)
    with meth h_ok frames Φ_pc' σ'
    have ?thesis by (unfold correct_state_def) (fastforce dest: sees_method_fun)
  }
  ultimately
  show ?thesis by (cases "?match") blast+ 
qed
(*>*)


subsection ‹Single Instructions›

text ‹
  In this section we prove for each single (welltyped) instruction
  that the state after execution of the instruction still conforms.
  Since we have already handled exceptions above, we can now assume that
  no exception occurs in this step.
›

declare defs1 [simp]

lemma Invoke_correct: 
  fixes σ' :: jvm_state
  assumes wtprog: "wf_jvm_progΦ P"
  assumes meth_C: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:    "ins ! pc = Invoke M' n"
  assumes wti:    "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes σ': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes approx: "P,Φ  (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_xcp: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
  shows "P,Φ  σ'" 
(*<*)
proof -
  note split_paired_Ex [simp del]
  
  from wtprog obtain wfmb where wfprog: "wf_prog wfmb P" 
    by (simp add: wf_jvm_prog_phi_def)
      
  from ins meth_C approx obtain ST LT where
    heap_ok: "P h" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs"
    by (fastforce dest: sees_method_fun)

  from ins wti Φ_pc
  have n: "n < size ST" by simp
  
  { assume "stk!n = Null"
    with ins no_xcp have False by (simp add: split_beta)
    hence ?thesis ..
  } 
  moreover
  { assume "ST!n = NT"
    moreover 
    from frame have "P,h  stk [:≤] ST" by simp
    with n have "P,h  stk!n :≤ ST!n" by (simp add: list_all2_conv_all_nth)
    ultimately 
    have "stk!n = Null" by simp
    with ins no_xcp have False by (simp add: split_beta)
    hence ?thesis ..
  } 
  moreover {
    assume NT: "ST!n  NT" and Null: "stk!n  Null"
    
    from NT ins wti Φ_pc obtain D D' Ts T m ST' LT' where
      D:   "ST!n = Class D" and
      pc': "pc+1 < size ins" and
      m_D: "P  D sees M': TsT = m in D'" and
      Ts:  "P  rev (take n ST) [≤] Ts" and
      Φ':  "Φ C M ! (pc+1) = Some (ST', LT')" and
      LT': "P  LT [≤] LT'" and
      ST': "P  (T # drop (n+1) ST) [≤] ST'"
      by (clarsimp simp add: sup_state_opt_any_Some)

    from frame obtain 
    stk: "P,h  stk [:≤] ST" and
    loc: "P,h  loc [:≤] LT" by simp
    
    from n stk D have "P,h  stk!n :≤ Class D"
      by (auto simp add: list_all2_conv_all_nth)
    with Null obtain a C' fs where
      Addr:   "stk!n = Addr a" and
      obj:    "h a = Some (C',fs)" and
      C'subD: "P  C' * D"
      by (fastforce dest!: conf_ClassD) 

    with wfprog m_D
    obtain Ts' T' m' D'' mxs' mxl' ins' xt' where
      m_C': "P  C' sees M': Ts'T' = (mxs',mxl',ins',xt') in D''" and
      T':   "P  T'  T" and
      Ts':  "P  Ts [≤] Ts'" 
      by (auto dest: sees_method_mono)

    let ?loc' = "Addr a # rev (take n stk) @ replicate mxl' undefined"
    let ?f' = "([], ?loc', D'', M', 0)"
    let ?f  = "(stk, loc, C, M, pc)"

    from Addr obj m_C' ins σ' meth_C
    have s': "σ' = (None, h, ?f' # ?f # frs)" by simp

    from Ts n have [simp]: "size Ts = n" 
      by (auto dest: list_all2_lengthD simp: min_def)
    with Ts' have [simp]: "size Ts' = n" 
      by (auto dest: list_all2_lengthD)

    from m_C' wfprog
    obtain mD'': "P  D'' sees M':Ts'T'=(mxs',mxl',ins',xt') in D''"
      by (fast dest: sees_method_idemp)
    moreover 
    with wtprog 
    obtain start: "wt_start P D'' Ts' mxl' (Φ D'' M')" and ins': "ins'  []"
      by (auto dest: wt_jvm_prog_impl_wt_start)    
    then obtain LT0 where LT0: "Φ D'' M' ! 0 = Some ([], LT0)"
      by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
    moreover
    have "conf_f P h ([], LT0) ins' ?f'"
    proof -
      let ?LT = "OK (Class D'') # (map OK Ts') @ (replicate mxl' Err)"

      from stk have "P,h  take n stk [:≤] take n ST" ..
      hence "P,h  rev (take n stk) [:≤] rev (take n ST)" by simp
      also note Ts also note Ts' finally
      have "P,h  rev (take n stk) [:≤] map OK Ts'" by simp 
      also
      have "P,h  replicate mxl' undefined [:≤] replicate mxl' Err" 
        by simp
      also from m_C' have "P  C' * D''" by (rule sees_method_decl_above)
      with obj have "P,h  Addr a :≤ Class D''" by (simp add: conf_def)
      ultimately
      have "P,h  ?loc' [:≤] ?LT" by simp
      also from start LT0 have "P   [≤] LT0" by (simp add: wt_start_def)
      finally have "P,h  ?loc' [:≤] LT0" .
      thus ?thesis using ins' by simp
    qed
    ultimately
    have ?thesis using s' Φ_pc approx meth_C m_D T' ins D 
      by (fastforce dest: sees_method_fun [of _ C])
  }
  ultimately show ?thesis by blast
qed
(*>*)

declare list_all2_Cons2 [iff]

lemma Return_correct:
  fixes σ' :: jvm_state
  assumes wt_prog: "wf_jvm_progΦ P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins: "ins ! pc = Return"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes correct: "P,Φ  (None, h, (stk,loc,C,M,pc)#frs)"

  shows "P,Φ  σ'"
(*<*)
proof -
  from wt_prog 
  obtain wfmb where wf: "wf_prog wfmb P" by (simp add: wf_jvm_prog_phi_def)

  from meth ins s'
  have "frs = []  ?thesis" by (simp add: correct_state_def)
  moreover
  { fix f frs' assume frs': "frs = f#frs'"
    moreover obtain stk' loc' C' M' pc' where 
      f: "f = (stk',loc',C',M',pc')" by (cases f)
    moreover note meth ins s'
    ultimately
    have σ':
      "σ' = (None,h,(hd stk#(drop (1+size Ts) stk'),loc',C',M',pc'+1)#frs')"
      (is "σ' = (None,h,?f'#frs')")
      by simp
    
    from correct meth
    obtain ST LT where
      h_ok:   "P  h " and
      Φ_pc: "Φ C M ! pc = Some (ST, LT)" and
      frame:  "conf_f P h (ST, LT) ins (stk,loc,C,M,pc)" and
      frames: "conf_fs P h Φ M (size Ts) T frs"
      by (auto dest: sees_method_fun simp add: correct_state_def)

    from Φ_pc ins wt
    obtain U ST0 where "ST = U # ST0" "P  U  T"
      by (simp add: wt_instr_def app_def) blast    
    with wf frame 
    have hd_stk: "P,h  hd stk :≤ T" by (auto simp add: conf_f_def)

    from f frs' frames
    obtain ST' LT' Ts'' T'' mxs' mxl0' ins' xt' D Ts' T' m D' where
      Φ': "Φ C' M' ! pc' = Some (ST', LT')" and
      meth_C':  "P  C' sees M':Ts''T''=(mxs',mxl0',ins',xt') in C'" and
      ins': "ins' ! pc' = Invoke M (size Ts)" and
      D: "ST' ! (size Ts) = Class D" and
      meth_D: "P  D sees M: Ts'T' = m in D'" and
      T': "P  T  T'" and
      frame':   "conf_f P h (ST',LT') ins' f" and
      conf_fs:  "conf_fs P h Φ M' (size Ts'') T'' frs'"
      by clarsimp

    from f frame' obtain
      stk': "P,h  stk' [:≤] ST'" and
      loc': "P,h  loc' [:≤] LT'" and
      pc':  "pc' < size ins'"
      by (simp add: conf_f_def)
    
    from wt_prog meth_C' pc'  
    have "P,T'',mxs',size ins',xt'  ins'!pc',pc' :: Φ C' M'"
      by (rule wt_jvm_prog_impl_wt_instr)
    with ins' Φ' D meth_D
    obtain aTs ST'' LT'' where
      Φ_suc:   "Φ C' M' ! Suc pc' = Some (ST'', LT'')" and
      less:    "P  (T' # drop (size Ts+1) ST', LT') i (ST'', LT'')" and
      suc_pc': "Suc pc' < size ins'" 
      by (clarsimp simp add: sup_state_opt_any_Some)

    from hd_stk T' have hd_stk': "P,h  hd stk :≤ T'"  ..
        
    have frame'':
      "conf_f P h (ST'',LT'') ins' ?f'" 
    proof -
      from stk'
      have "P,h  drop (1+size Ts) stk' [:≤] drop (1+size Ts) ST'" ..
      moreover
      with hd_stk' less
      have "P,h  hd stk # drop (1+size Ts) stk' [:≤] ST''" by auto
      moreover
      from wf loc' less have "P,h  loc' [:≤] LT''" by auto
      moreover note suc_pc' 
      ultimately show ?thesis by (simp add: conf_f_def)
    qed

    with σ' frs' f meth h_ok hd_stk Φ_suc frames meth_C' Φ'  
    have ?thesis by (fastforce dest: sees_method_fun [of _ C'])
  }
  ultimately
  show ?thesis by (cases frs) blast+
qed
(*>*)

declare sup_state_opt_any_Some [iff]
declare not_Err_eq [iff]

lemma Load_correct:
" wf_prog wt P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Load idx; 
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs); 
    P,Φ  (None, h, (stk,loc,C,M,pc)#frs) 
 P,Φ  σ'"
  by (fastforce dest: sees_method_fun [of _ C] elim!: confTs_confT_sup)

declare [[simproc del: list_to_set_comprehension]]

lemma Store_correct:
" wf_prog wt P;
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C;
  ins!pc = Store idx;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M;
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs) 
 P,Φ  σ'"
(*<*)
  apply clarsimp 
  apply (drule (1) sees_method_fun)
  apply clarsimp
  apply (blast intro!: list_all2_update_cong)
  done
(*>*)


lemma Push_correct:
" wf_prog wt P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Push v;
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
    P,Φ  (None, h, (stk,loc,C,M,pc)#frs) 
 P,Φ  σ'" 
(*<*)
  apply clarsimp 
  apply (drule (1) sees_method_fun)
  apply clarsimp
  apply (blast dest: typeof_lit_conf)
  done
(*>*)


lemma Cast_conf2:
  " wf_prog ok P; P,h  v :≤ T; is_refT T; cast_ok P C h v; 
     P  Class C  T'; is_class P C 
   P,h  v :≤ T'"
(*<*)
  apply (unfold cast_ok_def is_refT_def)
  apply (frule Class_widen)
  apply (elim exE disjE) 
     apply simp
    apply simp
   apply simp  
  apply (clarsimp simp add: conf_def obj_ty_def)
  apply (cases v)
  apply (auto intro: rtrancl_trans)
  done
(*>*)


lemma Checkcast_correct:
" wf_jvm_progΦ P;
    P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
    ins!pc = Checkcast D; 
    P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
    Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
    P,Φ  (None, h, (stk,loc,C,M,pc)#frs);
    fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None  
 P,Φ  σ'"
(*<*)
  apply (clarsimp simp add: wf_jvm_prog_phi_def split: if_split_asm)
  apply (drule (1) sees_method_fun)
  apply (blast intro: Cast_conf2)
  done
(*>*)

declare split_paired_All [simp del]

lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P

lemma Getfield_correct:
  fixes σ' :: jvm_state
  assumes wf: "wf_prog wt P"
  assumes mC: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes i:  "ins!pc = Getfield F D"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes cf: "P,Φ  (None, h, (stk,loc,C,M,pc)#frs)"
  assumes xc: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"

  shows "P,Φ  σ'"
(*<*)
proof -
  from mC cf obtain ST LT where    
    "h√": "P  h " and
    Φ: "Φ C M ! pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    fs: "conf_fs P h Φ M (size Ts) T frs"
    by (fastforce dest: sees_method_fun)
       
  from i Φ wt obtain oT ST'' vT ST' LT' vT' where 
    oT: "P  oT  Class D" and
    ST: "ST = oT # ST''" and
    F:  "P  D sees F:vT in D" and
    pc': "pc+1 < size ins"  and
    Φ': "Φ C M ! (pc+1) = Some (vT'#ST', LT')" and
    ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'" and  
    vT': "P  vT  vT'"
    by fastforce                       

  from stk ST obtain ref stk' where 
    stk': "stk = ref#stk'" and
    ref:  "P,h  ref :≤ oT" and
    ST'': "P,h  stk' [:≤] ST''"
    by auto

  from stk' i mC s' xc have "ref  Null"
    by (simp add: split_beta split:if_split_asm)
  moreover from ref oT have "P,h  ref :≤ Class D" ..
  ultimately obtain a D' fs where 
    a: "ref = Addr a" and h: "h a = Some (D', fs)" and D': "P  D' * D"
    by (blast dest: non_npD)

  from D' F have has_field: "P  D' has F:vT in D"      
    by (blast intro: has_field_mono has_visible_field)
  moreover from "h√" h have "P,h  (D', fs) " by (rule hconfD)
  ultimately obtain v where v: "fs (F, D) = Some v" "P,h  v :≤ vT"
    by (clarsimp simp add: oconf_def has_field_def)        
       (blast dest: has_fields_fun)

  from a h i mC s' stk' v
  have "σ' = (None, h, (v#stk',loc,C,M,pc+1)#frs)" by simp
  moreover
  from ST'' ST' have "P,h  stk' [:≤] ST'" ..
  moreover
  from v vT' have "P,h  v :≤ vT'" by blast
  moreover
  from loc LT' have "P,h  loc [:≤] LT'" ..
  moreover
  note "h√" mC Φ' pc' v fs
  ultimately
  show "P,Φ  σ' " by fastforce
qed
(*>*)

lemma Putfield_correct:
  fixes σ' :: jvm_state
  assumes wf: "wf_prog wt P"
  assumes mC: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes i:  "ins!pc = Putfield F D"
  assumes wt: "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes cf: "P,Φ  (None, h, (stk,loc,C,M,pc)#frs)"
  assumes xc: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"

  shows "P,Φ  σ'"
(*<*)
proof -
  from mC cf obtain ST LT where    
    "h√": "P  h " and    
    Φ: "Φ C M ! pc = Some (ST,LT)" and
    stk: "P,h  stk [:≤] ST" and loc: "P,h  loc [:≤] LT" and
    pc: "pc < size ins" and 
    fs: "conf_fs P h Φ M (size Ts) T frs"
    by (fastforce dest: sees_method_fun)
  
  from i Φ wt obtain vT vT' oT ST'' ST' LT' where 
    ST: "ST = vT # oT # ST''" and
    field: "P  D sees F:vT' in D" and
    oT: "P  oT  Class D" and vT: "P  vT  vT'" and
    pc': "pc+1 < size ins" and 
    Φ': "Φ C M!(pc+1) = Some (ST',LT')" and
    ST': "P  ST'' [≤] ST'" and LT': "P  LT [≤] LT'"
    by clarsimp

  from stk ST obtain v ref stk' where 
    stk': "stk = v#ref#stk'" and
    v:    "P,h  v :≤ vT" and 
    ref:  "P,h  ref :≤ oT" and
    ST'': "P,h  stk' [:≤] ST''"
    by auto

  from stk' i mC s' xc have "ref  Null" by (auto simp add: split_beta)
  moreover from ref oT have "P,h  ref :≤ Class D" ..
  ultimately obtain a D' fs where 
    a: "ref = Addr a" and h: "h a = Some (D', fs)" and D': "P  D' * D"
    by (blast dest: non_npD)

  from v vT have vT': "P,h  v :≤ vT'" ..

  from field D' have has_field: "P  D' has F:vT' in D"
    by (blast intro: has_field_mono has_visible_field)

  let ?h' = "h(a(D', fs((F, D)v)))" and ?f' = "(stk',loc,C,M,pc+1)"
  from h have hext: "h  ?h'" by (rule hext_upd_obj) 

  from a h i mC s' stk' 
  have "σ' = (None, ?h', ?f'#frs)" by simp
  moreover
  from "h√" h have "P,h  (D',fs)" by (rule hconfD) 
  with has_field vT' have "P,h  (D',fs((F, D)v))" ..
  with "h√" h have "P  ?h'" by (rule hconf_upd_obj)
  moreover
  from ST'' ST' have "P,h  stk' [:≤] ST'" ..
  from this hext have "P,?h'  stk' [:≤] ST'" by (rule confs_hext)
  moreover
  from loc LT' have "P,h  loc [:≤] LT'" ..
  from this hext have "P,?h'  loc [:≤] LT'" by (rule confTs_hext)
  moreover
  from fs hext
  have "conf_fs P ?h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
  moreover
  note mC Φ' pc' 
  ultimately
  show "P,Φ  σ' " by fastforce
qed
(*>*)
  
(* FIXME: move *)
lemma has_fields_b_fields: 
  "P  C has_fields FDTs  fields P C = FDTs"
(*<*)
  apply (unfold fields_def)                    
  apply (blast intro: the_equality has_fields_fun)
  done                                                
(*>*)
  
(* FIXME: move *)
lemma oconf_blank [intro, simp]:
    "is_class P C; wf_prog wt P  P,h  blank P C "
(*<*)
  by (fastforce simp add: blank_def has_fields_b_fields oconf_init_fields
               dest: wf_Fields_Ex)
(*>*)

lemma obj_ty_blank [iff]: "obj_ty (blank P C) = Class C"
  by (simp add: blank_def)

lemma New_correct:
  fixes σ' :: jvm_state
  assumes wf:   "wf_prog wt P"
  assumes meth: "P  C sees M:TsT=(mxs,mxl0,ins,xt) in C"
  assumes ins:  "ins!pc = New X"
  assumes wt:   "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
  assumes exec: "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes conf: "P,Φ  (None, h, (stk,loc,C,M,pc)#frs)"
  assumes no_x: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
  shows "P,Φ  σ'"
(*<*)
proof - 
  from ins conf meth
  obtain ST LT where
    heap_ok: "P h" and
    Φ_pc:    "Φ C M!pc = Some (ST,LT)" and
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h Φ M (size Ts) T frs"
    by (auto dest: sees_method_fun)

  from Φ_pc ins wt
  obtain ST' LT' where
    is_class_X: "is_class P X" and
    mxs:       "size ST < mxs" and
    suc_pc:     "pc+1 < size ins" and
    Φ_suc:      "Φ C M!(pc+1) = Some (ST', LT')" and
    less:       "P  (Class X # ST, LT) i (ST', LT')"
    by auto

  from ins no_x obtain oref where new_Addr: "new_Addr h = Some oref" by auto
  hence h: "h oref = None" by (rule new_Addr_SomeD) 
  
  with exec ins meth new_Addr have σ':
    "σ' = (None, h(oref  blank P X), (Addr oref#stk,loc,C,M,pc+1)#frs)"
    (is "σ' = (None, ?h', ?f # frs)")
    by simp    
  moreover
  from wf h heap_ok is_class_X have h': "P  ?h' "
    by (auto intro: hconf_new)
  moreover
  from h frame less suc_pc wf
  have "conf_f P ?h' (ST', LT') ins ?f"
    apply (clarsimp simp add: fun_upd_apply conf_def blank_def split_beta)
    apply (auto intro: confs_hext confTs_hext)
    done      
  moreover
  from h have "h  ?h'" by simp
  with frames have "conf_fs P ?h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
  ultimately
  show ?thesis using meth Φ_suc by fastforce 
qed
(*>*)


lemma Goto_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Goto branch; 
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs)  
 P,Φ  σ'"
(*<*)
apply clarsimp 
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)


lemma IfFalse_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = IfFalse branch; 
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs)  
 P,Φ  σ'"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma CmpEq_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = CmpEq;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs)  
 P,Φ  σ'"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma Pop_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Pop;
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs)  
 P,Φ  σ'"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)


lemma IAdd_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = IAdd; 
  P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M; 
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs)  
 P,Φ  σ'"
(*<*)
apply (clarsimp simp add: conf_def)
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)


lemma Throw_correct:
" wf_prog wt P; 
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C; 
  ins ! pc = Throw; 
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ; 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs);
  fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None  
 P,Φ  σ'"
  by simp


text ‹
  The next theorem collects the results of the sections above,
  i.e.~exception handling and the execution step for each 
  instruction. It states type safety for single step execution:
  in welltyped programs, a conforming state is transformed
  into another conforming state when one instruction is executed.
›
theorem instr_correct:
" wf_jvm_progΦ P;
  P  C sees M:TsT=(mxs,mxl0,ins,xt) in C;
  Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs); 
  P,Φ  (None, h, (stk,loc,C,M,pc)#frs)  
 P,Φ  σ'"
(*<*)
apply (subgoal_tac "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M")
 prefer 2
 apply (erule wt_jvm_prog_impl_wt_instr, assumption)
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply simp                                 
apply (cases "fst (exec_instr (ins!pc) P h stk loc C M pc frs)")
 prefer 2
 apply (erule xcpt_correct, assumption+) 
apply (frule wt_jvm_progD, erule exE)
apply (cases "ins!pc")
apply (rule Load_correct, assumption+)
apply (rule Store_correct, assumption+)
apply (rule Push_correct, assumption+)
apply (rule New_correct, assumption+)
apply (rule Getfield_correct, assumption+)
apply (rule Putfield_correct, assumption+)
apply (rule Checkcast_correct, assumption+)
apply (rule Invoke_correct, assumption+)
apply (rule Return_correct, assumption+)
apply (rule Pop_correct, assumption+)
apply (rule IAdd_correct, assumption+)
apply (rule Goto_correct, assumption+)
apply (rule CmpEq_correct, assumption+)
apply (rule IfFalse_correct, assumption+)
apply (rule Throw_correct, assumption+)
done
(*>*)

subsection ‹Main›

lemma correct_state_impl_Some_method:
  "P,Φ  (None, h, (stk,loc,C,M,pc)#frs) 
   m Ts T. P  C sees M:TsT = m in C"
  by fastforce

lemma BV_correct_1 [rule_format]:
"σ.  wf_jvm_progΦ P; P,Φ  σ  P  σ -jvm→1 σ'  P,Φ  σ'"
(*<*)
apply (simp only: split_tupled_all exec_1_iff)
apply (rename_tac xp h frs)
apply (case_tac xp)
 apply (case_tac frs)
  apply simp
 apply (simp only: split_tupled_all)
 apply hypsubst
 apply (frule correct_state_impl_Some_method)
 apply clarify
 apply (rule instr_correct)
 apply assumption+
 apply (rule sym)
 apply assumption+
apply (case_tac frs)
apply simp_all
done
(*>*)


theorem progress:
  " xp=None; frs[]   σ'. P  (xp,h,frs) -jvm→1 σ'"
  by (clarsimp simp add: exec_1_iff neq_Nil_conv split_beta
               simp del: split_paired_Ex)

lemma progress_conform:
  "wf_jvm_progΦ P; P,Φ  (xp,h,frs); xp=None; frs[] 
   σ'. P  (xp,h,frs) -jvm→1 σ'  P,Φ  σ'"
(*<*)
apply (drule progress)
apply assumption
apply (fast intro: BV_correct_1)
done
(*>*)

theorem BV_correct [rule_format]:
" wf_jvm_progΦ P; P  σ -jvm→ σ'   P,Φ  σ  P,Φ  σ'"
(*<*)
apply (simp only: exec_all_def1)
apply (erule rtrancl_induct)
 apply simp
apply clarify
apply (erule (2) BV_correct_1)
done
(*>*)

lemma hconf_start:   
  assumes wf: "wf_prog wf_mb P"
  shows "P  (start_heap P) "
(*<*)
  apply (unfold hconf_def)
  apply (simp add: preallocated_start)
  apply (clarify)
  apply (drule sym)
  apply (unfold start_heap_def)
  apply (insert wf)
  apply (auto simp add: fun_upd_apply is_class_xcpt split: if_split_asm)
  done
(*>*)
    
lemma BV_correct_initial: 
  shows " wf_jvm_progΦ P; P  C sees M:[]T = m in C 
   P,Φ  start_state P C M "
(*<*)
  apply (cases m)                            
  apply (unfold  start_state_def)
  apply (unfold correct_state_def)
  apply (simp del: defs1)
  apply (rule conjI)
   apply (simp add: wf_jvm_prog_phi_def hconf_start) 
  apply (drule wt_jvm_prog_impl_wt_start, assumption+)
  apply (unfold conf_f_def wt_start_def)
  apply fastforce
  done

declare [[simproc add: list_to_set_comprehension]]
(*>*)

theorem typesafe:
  assumes welltyped:   "wf_jvm_progΦ P"
  assumes main_method: "P  C sees M:[]T = m in C"
  shows "P  start_state P C M -jvm→ σ    P,Φ  σ "
(*<*)
proof -
  from welltyped main_method
  have "P,Φ  start_state P C M " by (rule BV_correct_initial)
  moreover
  assume "P  start_state P C M -jvm→ σ"
  ultimately  
  show "P,Φ  σ " using welltyped by - (rule BV_correct)
qed
(*>*)
  
end

Theory BVNoTypeError

(*  Title:      HOL/MicroJava/BV/BVNoTypeErrors.thy

    Author:     Gerwin Klein
    Copyright   GPL
*)

section ‹Welltyped Programs produce no Type Errors›

theory BVNoTypeError
imports "../JVM/JVMDefensive" BVSpecTypeSafe
begin

lemma has_methodI:
  "P  C sees M:TsT = m in D  P  C has M"
  by (unfold has_method_def) blast

text ‹
  Some simple lemmas about the type testing functions of the
  defensive JVM:
›
lemma typeof_NoneD [simp,dest]: "typeof v = Some x  ¬is_Addr v"
  by (cases v) auto

lemma is_Ref_def2:
  "is_Ref v = (v = Null  (a. v = Addr a))"
  by (cases v) (auto simp add: is_Ref_def)

lemma [iff]: "is_Ref Null" by (simp add: is_Ref_def2)

lemma is_RefI [intro, simp]: "P,h  v :≤ T  is_refT T  is_Ref v"
(*<*)
  apply (cases T)
  apply (auto simp add: is_refT_def is_Ref_def dest: conf_ClassD)
  done
(*>*)

lemma is_IntgI [intro, simp]: "P,h  v :≤ Integer  is_Intg v"
(*<*)
  apply (unfold conf_def)
  apply auto
  done
(*>*)

lemma is_BoolI [intro, simp]: "P,h  v :≤ Boolean  is_Bool v"
(*<*)
  apply (unfold conf_def)
  apply auto
  done
(*>*)

declare defs1 [simp del]

lemma wt_jvm_prog_states:
  " wf_jvm_progΦ P; P  C sees M: TsT = (mxs, mxl, ins, et) in C; 
     Φ C M ! pc = τ; pc < size ins 
   OK τ  states P mxs (1+size Ts+mxl)"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def check_types_def)
  apply (blast intro: nth_in)
  done
(*>*)

text ‹
  The main theorem: welltyped programs do not produce type errors if they
  are started in a conformant state.
›
theorem no_type_error:
  fixes σ :: jvm_state
  assumes welltyped: "wf_jvm_progΦ P" and conforms: "P,Φ  σ "
  shows "exec_d P σ  TypeError"
(*<*)
proof -
  from welltyped obtain mb where wf: "wf_prog mb P" by (fast dest: wt_jvm_progD)
  
  obtain xcp h frs where s [simp]: "σ = (xcp, h, frs)" by (cases σ)

  from conforms have "xcp  None  frs = []  check P σ" 
    by (unfold correct_state_def check_def) auto
  moreover {
    assume "¬(xcp  None  frs = [])"
    then obtain stk reg C M pc frs' where
      xcp [simp]: "xcp = None" and
      frs [simp]: "frs = (stk,reg,C,M,pc)#frs'" 
      by (clarsimp simp add: neq_Nil_conv)

    from conforms obtain  ST LT Ts T mxs mxl ins xt where
      hconf:  "P  h " and
      meth:   "P  C sees M:TsT = (mxs, mxl, ins, xt) in C" and
      Φ:      "Φ C M ! pc = Some (ST,LT)" and
      frame:  "conf_f P h (ST,LT) ins (stk,reg,C,M,pc)" and
      frames: "conf_fs P h Φ M (size Ts) T frs'"
      by (fastforce simp add: correct_state_def dest: sees_method_fun)
    
    from frame obtain
      stk: "P,h  stk [:≤] ST" and
      reg: "P,h  reg [:≤] LT" and
      pc:  "pc < size ins" 
      by (simp add: conf_f_def)

    from welltyped meth Φ pc
    have "OK (Some (ST, LT))  states P mxs (1+size Ts+mxl)"
      by (rule wt_jvm_prog_states)
    hence "size ST  mxs" by (auto simp add: JVM_states_unfold)
    with stk have mxs: "size stk  mxs" 
      by (auto dest: list_all2_lengthD)

    from welltyped meth pc
    have "P,T,mxs,size ins,xt  ins!pc,pc :: Φ C M"
      by (rule wt_jvm_prog_impl_wt_instr)
    hence app0: "app (ins!pc) P mxs T pc (size ins) xt (Φ C M!pc) "
      by (simp add: wt_instr_def)
    with Φ have eff: 
      "(pc',s')set (eff (ins ! pc) P pc xt (Φ C M ! pc)). pc' < size ins"
      by (unfold app_def) simp

    from app0 Φ have app:
      "xcpt_app (ins!pc) P pc mxs xt (ST,LT)  appi (ins!pc, P, pc, mxs, T, (ST,LT))"
      by (clarsimp simp add: app_def)

    with eff stk reg 
    have "check_instr (ins!pc) P h stk reg C M pc frs'"
    proof (cases "ins!pc")
      case (Getfield F C) 
      with app stk reg Φ obtain v vT stk' where
        field: "P  C sees F:vT in C" and
        stk:   "stk = v # stk'" and
        conf:  "P,h  v :≤ Class C"
        by auto
      from conf have is_Ref: "is_Ref v" by auto
      moreover {
        assume "v  Null" 
        with conf field is_Ref wf
        have "D vs. h (the_Addr v) = Some (D,vs)  P  D * C" 
          by (auto dest!: non_npD)
      }
      ultimately show ?thesis using Getfield field stk hconf
        apply clarsimp
        apply (rule conjI, fastforce)
        apply clarsimp
        apply (drule has_visible_field)
        apply (drule (1) has_field_mono)
        apply (drule (1) hconfD)
        apply (unfold oconf_def has_field_def)
        apply clarsimp
        apply (fastforce dest: has_fields_fun)
        done                            
    next
      case (Putfield F C)
      with app stk reg Φ obtain v ref vT stk' where
        field: "P  C sees F:vT in C" and
        stk:   "stk = v # ref # stk'" and
        confv: "P,h  v :≤ vT" and
        confr: "P,h  ref :≤ Class C"
        by fastforce
      from confr have is_Ref: "is_Ref ref" by simp
      moreover {
        assume "ref  Null" 
        with confr field is_Ref wf
        have "D vs. h (the_Addr ref) = Some (D,vs)  P  D * C"
          by (auto dest: non_npD)
      }
      ultimately show ?thesis using Putfield field stk confv by fastforce
    next      
      case (Invoke M' n)
      with app have n: "n < size ST" by simp

      from stk have [simp]: "size stk = size ST" by (rule list_all2_lengthD)
      
      { assume "stk!n = Null" with n Invoke have ?thesis by simp }
      moreover { 
        assume "ST!n = NT"
        with n stk have "stk!n = Null" by (auto simp: list_all2_conv_all_nth)
        with n Invoke have ?thesis by simp
      }
      moreover {
        assume Null: "stk!n  Null" and NT: "ST!n  NT"

        from NT app Invoke
        obtain D D' Ts T m where
          D:  "ST!n = Class D" and
          M': "P  D sees M': TsT = m in D'" and
          Ts: "P  rev (take n ST) [≤] Ts"
          by auto
        
        from D stk n have "P,h  stk!n :≤ Class D" 
          by (auto simp: list_all2_conv_all_nth)
        with Null obtain a C' fs where 
          [simp]: "stk!n = Addr a" "h a = Some (C',fs)" and
          "P  C' * D"
          by (fastforce dest!: conf_ClassD) 

        with M' wf obtain m' Ts' T' D'' where 
          C': "P  C' sees M': Ts'T' = m' in D''" and
          Ts': "P  Ts [≤] Ts'"
          by (auto dest!: sees_method_mono)

        from stk have "P,h  take n stk [:≤] take n ST" ..
        hence "P,h  rev (take n stk) [:≤] rev (take n ST)" ..
        also note Ts also note Ts'
        finally have "P,h  rev (take n stk) [:≤] Ts'" .

        with Invoke Null n C'
        have ?thesis by (auto simp add: is_Ref_def2 has_methodI)
      }
      ultimately show ?thesis by blast      
    next
      case Return with stk app Φ meth frames 
      show ?thesis by (auto simp add: has_methodI)
    qed (auto simp add: list_all2_lengthD)
    hence "check P σ" using meth pc mxs by (simp add: check_def has_methodI)
  } ultimately
  have "check P σ" by blast
  thus "exec_d P σ  TypeError" ..
qed
(*>*)


text ‹
  The theorem above tells us that, in welltyped programs, the
  defensive machine reaches the same result as the aggressive
  one (after arbitrarily many steps).
›
theorem welltyped_aggressive_imp_defensive:
  "wf_jvm_progΦ P  P,Φ  σ   P  σ -jvm→ σ'
   P  (Normal σ) -jvmd→ (Normal σ')"
(*<*)
  apply (simp only: exec_all_def) 
  apply (erule rtrancl_induct)
   apply (simp add: exec_all_d_def1)
  apply simp
  apply (simp only: exec_all_def [symmetric])
  apply (frule BV_correct, assumption+) 
  apply (drule no_type_error, assumption, drule no_type_error_commutes, simp)
  apply (simp add: exec_all_d_def1)
  apply (rule rtrancl_trans, assumption)
  apply (drule exec_1_d_NormalI)
  apply auto
  done
(*>*)


text ‹
  As corollary we get that the aggressive and the defensive machine
  are equivalent for welltyped programs (if started in a conformant
  state or in the canonical start state)
› 
corollary welltyped_commutes:
  fixes σ :: jvm_state
  assumes wf: "wf_jvm_progΦ P" and conforms: "P,Φ  σ " 
  shows "P  (Normal σ) -jvmd→ (Normal σ') = P  σ -jvm→ σ'"
  apply rule
  apply (erule defensive_imp_aggressive)
  apply (erule welltyped_aggressive_imp_defensive [OF wf conforms])
  done

corollary welltyped_initial_commutes:
  assumes wf: "wf_jvm_prog P"  
  assumes meth: "P  C sees M:[]T = b in C" 
  defines start: "σ  start_state P C M"
  shows "P  (Normal σ) -jvmd→ (Normal σ') = P  σ -jvm→ σ'"
proof -
  from wf obtain Φ where wf': "wf_jvm_progΦ P" by (auto simp: wf_jvm_prog_def)
  from this meth have "P,Φ  σ " unfolding start by (rule BV_correct_initial)
  with wf' show ?thesis by (rule welltyped_commutes)
qed


lemma not_TypeError_eq [iff]:
  "x  TypeError = (t. x = Normal t)"
  by (cases x) auto

locale cnf =
  fixes P and Φ and σ
  assumes wf: "wf_jvm_progΦ P"  
  assumes cnf: "correct_state P Φ σ" 

theorem (in cnf) no_type_errors:
  "P  (Normal σ) -jvmd→ σ'  σ'  TypeError"
  apply (unfold exec_all_d_def1)   
  apply (erule rtrancl_induct)
   apply simp
  apply (fold exec_all_d_def1)
  apply (insert cnf wf)
  apply clarsimp
  apply (drule defensive_imp_aggressive)
  apply (frule (2) BV_correct)
  apply (drule (1) no_type_error) back
  apply (auto simp add: exec_1_d_eq)
  done

locale start =
  fixes P and C and M and σ and T and b
  assumes wf: "wf_jvm_prog P"  
  assumes sees: "P  C sees M:[]T = b in C" 
  defines "σ  Normal (start_state P C M)"

corollary (in start) bv_no_type_error:
  shows "P  σ -jvmd→ σ'  σ'  TypeError"
proof -
  from wf obtain Φ where "wf_jvm_progΦ P" by (auto simp: wf_jvm_prog_def)
  moreover
  with sees have "correct_state P Φ (start_state P C M)" 
    by - (rule BV_correct_initial)
  ultimately have "cnf P Φ (start_state P C M)" by (rule cnf.intro)
  moreover assume "P  σ -jvmd→ σ'"
  ultimately show ?thesis by (unfold σ_def) (rule cnf.no_type_errors) 
qed

 
end  

Theory BVExample

(*  Title:      Jinja/BV/BVExample.thy

    Author:     Gerwin Klein
*)

section ‹Example Welltypings \label{sec:BVExample}›

theory BVExample
imports "../JVM/JVMListExample" BVSpecTypeSafe BVExec
  "HOL-Library.Code_Target_Numeral"
begin

text ‹
  This theory shows type correctness of the example program in section 
  \ref{sec:JVMListExample} (p. \pageref{sec:JVMListExample}) by
  explicitly providing a welltyping. It also shows that the start
  state of the program conforms to the welltyping; hence type safe
  execution is guaranteed.
›

subsection "Setup"

lemma distinct_classes':
  "list_name  test_name"
  "list_name  Object"
  "list_name  ClassCast"
  "list_name  OutOfMemory"
  "list_name  NullPointer"
  "test_name  Object"
  "test_name  OutOfMemory"
  "test_name  ClassCast"
  "test_name  NullPointer"
  "ClassCast  NullPointer"
  "ClassCast  Object"
  "NullPointer  Object"
  "OutOfMemory  ClassCast"
  "OutOfMemory  NullPointer"
  "OutOfMemory  Object"
  by (simp_all add: list_name_def test_name_def Object_def NullPointer_def
    OutOfMemory_def ClassCast_def)

lemmas distinct_classes = distinct_classes' distinct_classes' [symmetric]

lemma distinct_fields:
  "val_name  next_name"
  "next_name  val_name"
  by (simp_all add: val_name_def next_name_def)

text ‹Abbreviations for definitions we will have to use often in the
proofs below:›
lemmas system_defs = SystemClasses_def ObjectC_def NullPointerC_def 
                     OutOfMemoryC_def ClassCastC_def
lemmas class_defs  = list_class_def test_class_def

text ‹These auxiliary proofs are for efficiency: class lookup,
subclass relation, method and field lookup are computed only once:
›
lemma class_Object [simp]:
  "class E Object = Some (undefined, [],[])"
  by (simp add: class_def system_defs E_def)

lemma class_NullPointer [simp]:
  "class E NullPointer = Some (Object, [], [])"
  by (simp add: class_def system_defs E_def distinct_classes)

lemma class_OutOfMemory [simp]:
  "class E OutOfMemory = Some (Object, [], [])"
  by (simp add: class_def system_defs E_def distinct_classes)

lemma class_ClassCast [simp]:
  "class E ClassCast = Some (Object, [], [])"
  by (simp add: class_def system_defs E_def distinct_classes)

lemma class_list [simp]:
  "class E list_name = Some list_class"
  by (simp add: class_def system_defs E_def distinct_classes)
 
lemma class_test [simp]:
  "class E test_name = Some test_class"
  by (simp add: class_def system_defs E_def distinct_classes)

lemma E_classes [simp]:
  "{C. is_class E C} = {list_name, test_name, NullPointer, 
                        ClassCast, OutOfMemory, Object}"
  by (auto simp add: is_class_def class_def system_defs E_def class_defs)

text ‹The subclass releation spelled out:›
lemma subcls1:
  "subcls1 E = {(list_name,Object), (test_name,Object), (NullPointer, Object),
                (ClassCast, Object), (OutOfMemory, Object)}"
(*<*)
  apply (simp add: subcls1_def2)
  apply (simp add: class_defs system_defs E_def class_def)
  (* FIXME: cannot simply expand class names, since
     inequality proofs on strings are too inefficient *)
  apply (auto simp: distinct_classes split!: if_splits)
  done
(*>*)

text ‹The subclass relation is acyclic; hence its converse is well founded:›
lemma notin_rtrancl:
  "(a,b)  r*  a  b  (y. (a,y)  r)  False"
  by (auto elim: converse_rtranclE)

lemma acyclic_subcls1_E: "acyclic (subcls1 E)"
(*<*)
  apply (rule acyclicI)
  apply (simp add: subcls1)
  apply (auto dest!: tranclD)
  apply (auto elim!: notin_rtrancl simp add: distinct_classes)
  done
(*>*)

lemma wf_subcls1_E: "wf ((subcls1 E)¯)"
(*<*)
  apply (rule finite_acyclic_wf_converse)
  apply (simp add: subcls1)
  apply (rule acyclic_subcls1_E)
  done  
(*>*)

text ‹Method and field lookup:›

lemma method_append [simp]:
  "method E list_name append_name =
  (list_name, [Class list_name], Void, 3, 0, append_ins, [(1, 2, NullPointer, 7, 0)])"
(*<*)
  apply (insert class_list)
  apply (unfold list_class_def)
  apply (fastforce simp add: Method_def distinct_classes intro: method_def2 Methods.intros)
  done
(*>*)

lemma method_makelist [simp]:
  "method E test_name makelist_name = 
  (test_name, [], Void, 3, 2, make_list_ins, [])"
(*<*)
  apply (insert class_test)
  apply (unfold test_class_def)
  apply (fastforce simp add: Method_def distinct_classes intro: method_def2 Methods.intros)
  done
(*>*)

lemma field_val [simp]:
  "field E list_name val_name = (list_name, Integer)"
(*<*)
  apply (insert class_list)
  apply (unfold list_class_def)
  apply (fastforce simp add: sees_field_def distinct_classes intro: field_def2 Fields.intros)
  done
(*>*)

lemma field_next [simp]:
  "field E list_name next_name = (list_name, Class list_name)"
(*<*)
  apply (insert class_list)
  apply (unfold list_class_def)
  apply (fastforce simp add: distinct_fields sees_field_def distinct_classes intro: field_def2 Fields.intros)
  done
(*>*)

lemma [simp]: "fields E Object = []"
  by (fastforce intro: fields_def2 Fields.intros)
 
lemma [simp]: "fields E NullPointer = []"
  by (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)

lemma [simp]: "fields E ClassCast = []"
  by (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)

lemma [simp]: "fields E OutOfMemory = []"
  by (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)

lemma [simp]: "fields E test_name = []"
(*<*)
  apply (insert class_test)
  apply (unfold test_class_def)
  apply (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)
  done
(*>*)

lemmas [simp] = is_class_def


subsection "Program structure"

text ‹
  The program is structurally wellformed:
›
lemma wf_struct:
  "wf_prog (λG C mb. True) E" (is "wf_prog ?mb E")
(*<*)
proof -
  have "distinct_fst E" 
    by (simp add: system_defs E_def class_defs distinct_classes)
  moreover
  have "set SystemClasses  set E" by (simp add: system_defs E_def)
  hence "wf_syscls E" by (rule wf_syscls)
  moreover
  have "wf_cdecl ?mb E ObjectC" by (simp add: wf_cdecl_def ObjectC_def)
  moreover
  have "wf_cdecl ?mb E NullPointerC" 
    by (auto elim: notin_rtrancl 
            simp add: wf_cdecl_def distinct_classes NullPointerC_def subcls1)
  moreover
  have "wf_cdecl ?mb E ClassCastC" 
    by (auto elim: notin_rtrancl 
            simp add: wf_cdecl_def distinct_classes ClassCastC_def subcls1)
  moreover
  have "wf_cdecl ?mb E OutOfMemoryC" 
    by (auto elim: notin_rtrancl 
            simp add: wf_cdecl_def distinct_classes OutOfMemoryC_def subcls1)
  moreover
  have "wf_cdecl ?mb E (list_name, list_class)"
    apply (auto elim!: notin_rtrancl 
            simp add: wf_cdecl_def wf_fdecl_def list_class_def 
                      wf_mdecl_def subcls1)
    apply (auto simp add: distinct_classes distinct_fields Method_def elim: Methods.cases)
    done    
  moreover
  have "wf_cdecl ?mb E (test_name, test_class)" 
    apply (auto elim!: notin_rtrancl 
            simp add: wf_cdecl_def wf_fdecl_def test_class_def 
                      wf_mdecl_def subcls1)
    apply (auto simp add: distinct_classes distinct_fields Method_def elim: Methods.cases)
    done       
  ultimately
  show ?thesis by (simp add: wf_prog_def E_def SystemClasses_def)
qed
(*>*)

subsection "Welltypings"
text ‹
  We show welltypings of the methods @{term append_name} in class @{term list_name}, 
  and @{term makelist_name} in class @{term test_name}:
›
lemmas eff_simps [simp] = eff_def norm_eff_def xcpt_eff_def
(*declare app'Invoke [simp del]*)

definition phi_append :: tym ("φa")
where
  "φa  map (λ(x,y). Some (x, map OK y)) [ 
   (                                    [], [Class list_name, Class list_name]),
   (                     [Class list_name], [Class list_name, Class list_name]),
   (                     [Class list_name], [Class list_name, Class list_name]),
   (    [Class list_name, Class list_name], [Class list_name, Class list_name]),
   (    [Class list_name, Class list_name], [Class list_name, Class list_name]),
   ([NT, Class list_name, Class list_name], [Class list_name, Class list_name]),
   (            [Boolean, Class list_name], [Class list_name, Class list_name]),

   (                        [Class Object], [Class list_name, Class list_name]),
   (                                    [], [Class list_name, Class list_name]),
   (                     [Class list_name], [Class list_name, Class list_name]),
   (    [Class list_name, Class list_name], [Class list_name, Class list_name]),
   (                                    [], [Class list_name, Class list_name]),
   (                                [Void], [Class list_name, Class list_name]),

   (                     [Class list_name], [Class list_name, Class list_name]),
   (    [Class list_name, Class list_name], [Class list_name, Class list_name]),
   (                                [Void], [Class list_name, Class list_name])]"

text ‹
  The next definition and three proof rules implement an algorithm to
  enumarate natural numbers. The command apply (elim pc_end pc_next pc_0› 
  transforms a goal of the form
  @{prop [display] "pc < n  P pc"} 
  into a series of goals
  @{prop [display] "P 0"} 
  @{prop [display] "P (Suc 0)"} 

  …›

  @{prop [display] "P n"}
definition intervall :: "nat  nat  nat  bool" ("_  [_, _')")
where
  "x  [a, b)  a  x  x < b"

lemma pc_0: "x < n  (x  [0, n)  P x)  P x"
  by (simp add: intervall_def)

lemma pc_next: "x  [n0, n)  P n0  (x  [Suc n0, n)  P x)  P x"
(*<*)
  apply (cases "x=n0")
  apply (auto simp add: intervall_def)
  done
(*>*)

lemma pc_end: "x  [n,n)  P x" 
  by (unfold intervall_def) arith


lemma types_append [simp]: "check_types E 3 (Suc (Suc 0)) (map OK φa)"
(*<*)
  by (auto simp add: check_types_def phi_append_def JVM_states_unfold)
(*>*)

lemma wt_append [simp]:
  "wt_method E list_name [Class list_name] Void 3 0 append_ins
             [(Suc 0, 2, NullPointer, 7, 0)] φa"
(*<*)
  apply (simp add: wt_method_def wt_start_def wt_instr_def)
  apply (simp add: append_ins_def phi_append_def)
  apply clarify
  apply (drule sym)
  apply (erule_tac P="x = y" for x y in rev_mp)
  apply (elim pc_end pc_next pc_0)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add: matches_ex_entry_def subcls1
    relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
    distinct_classes distinct_fields intro: Fields.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
    distinct_classes distinct_fields intro: Fields.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add: relevant_entries_def is_relevant_entry_def subcls1)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
    distinct_classes distinct_fields intro: Fields.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def list_class_def
    distinct_classes Method_def intro: Methods.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  done
(*>*)

text ‹Some abbreviations for readability› 
abbreviation "Clist == Class list_name"
abbreviation "Ctest == Class test_name"

definition phi_makelist :: tym ("φm")
where
  "φm  map (λ(x,y). Some (x, y)) [ 
    (                                   [], [OK Ctest, Err     , Err     ]),
    (                              [Clist], [OK Ctest, Err     , Err     ]),
    (                                   [], [OK Clist, Err     , Err     ]),
    (                              [Clist], [OK Clist, Err     , Err     ]),
    (                     [Integer, Clist], [OK Clist, Err     , Err     ]),

    (                                   [], [OK Clist, Err     , Err     ]),
    (                              [Clist], [OK Clist, Err     , Err     ]),
    (                                   [], [OK Clist, OK Clist, Err     ]),
    (                              [Clist], [OK Clist, OK Clist, Err     ]),
    (                     [Integer, Clist], [OK Clist, OK Clist, Err     ]),

    (                                   [], [OK Clist, OK Clist, Err     ]),
    (                              [Clist], [OK Clist, OK Clist, Err     ]),
    (                                   [], [OK Clist, OK Clist, OK Clist]),
    (                              [Clist], [OK Clist, OK Clist, OK Clist]),
    (                     [Integer, Clist], [OK Clist, OK Clist, OK Clist]),

    (                                   [], [OK Clist, OK Clist, OK Clist]),
    (                              [Clist], [OK Clist, OK Clist, OK Clist]),
    (                       [Clist, Clist], [OK Clist, OK Clist, OK Clist]),
    (                               [Void], [OK Clist, OK Clist, OK Clist]),
    (                                   [], [OK Clist, OK Clist, OK Clist]),
    (                              [Clist], [OK Clist, OK Clist, OK Clist]),
    (                       [Clist, Clist], [OK Clist, OK Clist, OK Clist]),
    (                               [Void], [OK Clist, OK Clist, OK Clist])]"

lemma types_makelist [simp]: "check_types E 3 (Suc (Suc (Suc 0))) (map OK φm)"
(*<*)
  by (auto simp add: check_types_def phi_makelist_def JVM_states_unfold)
(*>*)

lemma wt_makelist [simp]:
  "wt_method E test_name [] Void 3 2 make_list_ins [] φm"
(*<*)
  apply (simp add: wt_method_def)
  apply (unfold make_list_ins_def phi_makelist_def)
  apply (simp add: wt_start_def eval_nat_numeral)
  apply (simp add: wt_instr_def)
  apply clarify
  apply (drule sym)
  apply (erule_tac P="x = y" for x y in rev_mp)
  apply (elim pc_end pc_next pc_0)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
    distinct_classes intro: Fields.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
    distinct_classes intro: Fields.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
    distinct_classes intro: Fields.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def list_class_def
    distinct_classes Method_def intro: Methods.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  apply (fastforce simp add:
    relevant_entries_def is_relevant_entry_def list_class_def
    distinct_classes Method_def intro: Methods.intros)
  apply (simp add: relevant_entries_def is_relevant_entry_def)
  done
(*>*)

lemma wf_md'E:
  " wf_prog wf_md P; 
     C S fs ms m.(C,S,fs,ms)  set P; m  set ms  wf_md' P C m 
   wf_prog wf_md' P"
(*<*)
  apply (simp add: wf_prog_def)
  apply auto
  apply (simp add: wf_cdecl_def wf_mdecl_def)
  apply fastforce
  done
(*>*)

text ‹The whole program is welltyped:›
definition Phi :: tyP ("Φ")
where
  "Φ C mn  if C = test_name  mn = makelist_name then φm else 
             if C = list_name  mn = append_name then φa else []"

lemma wf_prog:
  "wf_jvm_progΦ E" 
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (rule wf_md'E [OF wf_struct])
  apply (simp add: E_def)
  apply clarify
  apply (fold E_def)
  apply (simp add: system_defs class_defs Phi_def)
  apply auto
  apply (simp add: distinct_classes)
  done 
(*>*)


subsection "Conformance"
text ‹Execution of the program will be typesafe, because its
  start state conforms to the welltyping:›

lemma "E,Φ  start_state E test_name makelist_name "
(*<*)
  apply (rule BV_correct_initial)
    apply (rule wf_prog)
  apply (fastforce simp add: test_class_def distinct_classes Method_def intro: Methods.intros)
  done
(*>*)


subsection "Example for code generation: inferring method types"

definition test_kil :: "jvm_prog  cname  ty list  ty  nat  nat  
             ex_table  instr list  tyi' err list"
where
  "test_kil G C pTs rT mxs mxl et instr 
   (let first  = Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err));
        start  = OK first#(replicate (size instr - 1) (OK None))
    in  kiljvm G mxs (1+size pTs+mxl) rT instr et start)"


lemma [code]:
  "unstables r step ss = 
   fold (λp A. if ¬stable r step ss p then insert p A else A) [0..<size ss] {}"
proof -
  have "unstables r step ss = (UN p:{..<size ss}. if ¬stable r step ss p then {p} else {})"
    apply (unfold unstables_def)
    apply (rule equalityI)
    apply (rule subsetI)
    apply (erule CollectE)
    apply (erule conjE)
    apply (rule UN_I)
    apply simp
    apply simp
    apply (rule subsetI)
    apply (erule UN_E)
    apply (case_tac "¬ stable r step ss p")
    apply simp+
    done
  also have "f. (UN p:{..<size ss}. f p) = Union (set (map f [0..<size ss]))" by auto
  also note Sup_set_fold also note fold_map
  also have "(∪)  (λp. if ¬ stable r step ss p then {p} else {}) = 
            (λp A. if ¬stable r step ss p then insert p A else A)"
    by(auto simp add: fun_eq_iff)
  finally show ?thesis .
qed

definition some_elem :: "'a set  'a" where [code del]:
  "some_elem = (%S. SOME x. x : S)"
code_printing
  constant some_elem  (SML) "(case/ _ of/ Set/ xs/ =>/ hd/ xs)"

text ‹This code setup is just a demonstration and \emph{not} sound!›
notepad begin
  have "some_elem (set [False, True]) = False" by eval
  moreover have "some_elem (set [True, False]) = True" by eval
  ultimately have False by (simp add: some_elem_def)
end

lemma [code]:
  "iter f step ss w = while (λ(ss, w). ¬ Set.is_empty w)
    (λ(ss, w).
        let p = some_elem w in propa f (step p (ss ! p)) ss (w - {p}))
    (ss, w)"
  unfolding iter_def Set.is_empty_def some_elem_def ..

lemma JVM_sup_unfold [code]:
 "JVM_SemiType.sup S m n = lift2 (Opt.sup
       (Product.sup (Listn.sup (SemiType.sup S))
         (λx y. OK (map2 (lift2 (SemiType.sup S)) x y))))" 
  apply (unfold JVM_SemiType.sup_def JVM_SemiType.sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def  
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  by simp

lemmas [code] = SemiType.sup_def [unfolded exec_lub_def] JVM_le_unfold

lemmas [code] = lesub_def plussub_def

lemma [code]:
  "is_refT T = (case T of NT  True | Class C  True | _  False)"
  by (simp add: is_refT_def split: ty.split)

declare appi.simps [code]

lemma [code]:
  "appi (Getfield F C, P, pc, mxs, Tr, (T#ST, LT)) = 
    Predicate.holds (Predicate.bind (sees_field_i_i_i_o_i P C F C) (λTf. if P  T  Class C then Predicate.single () else bot))"
by(auto simp add: Predicate.holds_eq intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)

lemma [code]:
  "appi (Putfield F C, P, pc, mxs, Tr, (T1#T2#ST, LT)) = 
     Predicate.holds (Predicate.bind (sees_field_i_i_i_o_i P C F C) (λTf. if P  T2  (Class C)  P  T1  Tf then Predicate.single () else bot))"
by(auto simp add: Predicate.holds_eq simp del: eval_bind split: if_split_asm elim!: sees_field_i_i_i_o_iE Predicate.bindE intro: Predicate.bindI sees_field_i_i_i_o_iI)

lemma [code]:
  "appi (Invoke M n, P, pc, mxs, Tr, (ST,LT)) =
    (n < length ST  
    (ST!n  NT 
      (case ST!n of
         Class C  Predicate.holds (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (λ(Ts, T, m, D). if P  rev (take n ST) [≤] Ts then Predicate.single () else bot))
       | _  False)))"
by (fastforce simp add: Predicate.holds_eq simp del: eval_bind split: ty.split_asm if_split_asm intro: bindI Method_i_i_i_o_o_o_oI elim!: bindE Method_i_i_i_o_o_o_oE)

lemmas [code] =
  SemiType.sup_def [unfolded exec_lub_def]
  widen.equation
  is_relevant_class.simps

definition test1 where
  "test1 = test_kil E list_name [Class list_name] Void 3 0
    [(Suc 0, 2, NullPointer, 7, 0)] append_ins"
definition test2 where
  "test2 = test_kil E test_name [] Void 3 2 [] make_list_ins"
definition test3 where "test3 = φa"
definition test4 where "test4 = φm"

ML_val if @{code test1} = @{code map} @{code OK} @{code test3} then () else error "wrong result";
  if @{code test2} = @{code map} @{code OK} @{code test4} then () else error "wrong result"

end

Theory J1

(*  Title:      Jinja/Compiler/J1.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

chapter ‹Compilation \label{cha:comp}›

section ‹An Intermediate Language›

theory J1 imports "../J/BigStep" begin

type_synonym expr1 = "nat exp"
type_synonym J1_prog = "expr1 prog"
type_synonym state1 = "heap × (val list)"

primrec
  max_vars :: "'a exp  nat"
  and max_varss :: "'a exp list  nat"
where
  "max_vars(new C) = 0"
| "max_vars(Cast C e) = max_vars e"
| "max_vars(Val v) = 0"
| "max_vars(e1 «bop» e2) = max (max_vars e1) (max_vars e2)"
| "max_vars(Var V) = 0"
| "max_vars(V:=e) = max_vars e"
| "max_vars(eF{D}) = max_vars e"
| "max_vars(FAss e1 F D e2) = max (max_vars e1) (max_vars e2)"
| "max_vars(eM(es)) = max (max_vars e) (max_varss es)"
| "max_vars({V:T; e}) = max_vars e + 1"
| "max_vars(e1;;e2) = max (max_vars e1) (max_vars e2)"
| "max_vars(if (e) e1 else e2) =
   max (max_vars e) (max (max_vars e1) (max_vars e2))"
| "max_vars(while (b) e) = max (max_vars b) (max_vars e)"
| "max_vars(throw e) = max_vars e"
| "max_vars(try e1 catch(C V) e2) = max (max_vars e1) (max_vars e2 + 1)"

| "max_varss [] = 0"
| "max_varss (e#es) = max (max_vars e) (max_varss es)"

inductive
  eval1 :: "J1_prog  expr1  state1  expr1  state1  bool"
          ("_ 1 ((1_,/_) / (1_,/_))" [51,0,0,0,0] 81)
  and evals1 :: "J1_prog  expr1 list  state1  expr1 list  state1  bool"
           ("_ 1 ((1_,/_) [⇒]/ (1_,/_))" [51,0,0,0,0] 81)
  for P :: J1_prog
where

  New1:
  " new_Addr h = Some a; P  C has_fields FDTs; h' = h(a(C,init_fields FDTs)) 
   P 1 new C,(h,l)  addr a,(h',l)"
| NewFail1:
  "new_Addr h = None 
  P 1 new C, (h,l)  THROW OutOfMemory,(h,l)"

| Cast1:
  " P 1 e,s0  addr a,(h,l); h a = Some(D,fs); P  D * C 
   P 1 Cast C e,s0  addr a,(h,l)"
| CastNull1:
  "P 1 e,s0  null,s1 
  P 1 Cast C e,s0  null,s1"
| CastFail1:
  " P 1 e,s0  addr a,(h,l); h a = Some(D,fs); ¬ P  D * C 
   P 1 Cast C e,s0  THROW ClassCast,(h,l)"
| CastThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 Cast C e,s0  throw e',s1"

| Val1:
  "P 1 Val v,s  Val v,s"

| BinOp1:
  " P 1 e1,s0  Val v1,s1; P 1 e2,s1  Val v2,s2; binop(bop,v1,v2) = Some v 
   P 1 e1 «bop» e2,s0  Val v,s2"
| BinOpThrow11:
  "P 1 e1,s0  throw e,s1 
  P 1 e1 «bop» e2, s0  throw e,s1"
| BinOpThrow21:
  " P 1 e1,s0  Val v1,s1; P 1 e2,s1  throw e,s2 
   P 1 e1 «bop» e2,s0  throw e,s2"

| Var1:
  " ls!i = v; i < size ls  
  P 1 Var i,(h,ls)  Val v,(h,ls)"

| LAss1:
  " P 1 e,s0  Val v,(h,ls); i < size ls; ls' = ls[i := v] 
   P 1 i:= e,s0  unit,(h,ls')"
| LAssThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 i:= e,s0  throw e',s1"

| FAcc1:
  " P 1 e,s0  addr a,(h,ls); h a = Some(C,fs); fs(F,D) = Some v 
   P 1 eF{D},s0  Val v,(h,ls)"
| FAccNull1:
  "P 1 e,s0  null,s1 
  P 1 eF{D},s0  THROW NullPointer,s1"
| FAccThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 eF{D},s0  throw e',s1"

| FAss1:
  " P 1 e1,s0  addr a,s1; P 1 e2,s1  Val v,(h2,l2);
    h2 a = Some(C,fs); fs' = fs((F,D)v); h2' = h2(a(C,fs')) 
   P 1 e1F{D}:= e2,s0  unit,(h2',l2)"
| FAssNull1:
  " P 1 e1,s0  null,s1;  P 1 e2,s1  Val v,s2 
   P 1 e1F{D}:= e2,s0  THROW NullPointer,s2"
| FAssThrow11:
  "P 1 e1,s0  throw e',s1 
  P 1 e1F{D}:= e2,s0  throw e',s1"
| FAssThrow21:
  " P 1 e1,s0  Val v,s1; P 1 e2,s1  throw e',s2 
   P 1 e1F{D}:= e2,s0  throw e',s2"

| CallObjThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 eM(es),s0  throw e',s1"
| CallNull1:
  " P 1 e,s0  null,s1; P 1 es,s1 [⇒] map Val vs,s2 
   P 1 eM(es),s0  THROW NullPointer,s2"
| Call1:
  " P 1 e,s0  addr a,s1; P 1 es,s1 [⇒] map Val vs,(h2,ls2);
    h2 a = Some(C,fs); P  C sees M:TsT = body in D;
    size vs = size Ts; ls2' = (Addr a) # vs @ replicate (max_vars body) undefined;
    P 1 body,(h2,ls2')  e',(h3,ls3) 
   P 1 eM(es),s0  e',(h3,ls2)"
| CallParamsThrow1:
  " P 1 e,s0  Val v,s1; P 1 es,s1 [⇒] es',s2;
     es' = map Val vs @ throw ex # es2 
    P 1 eM(es),s0  throw ex,s2"

| Block1:
  "P 1 e,s0  e',s1  P 1 Block i T e,s0  e',s1"

| Seq1:
  " P 1 e0,s0  Val v,s1; P 1 e1,s1  e2,s2 
   P 1 e0;;e1,s0  e2,s2"
| SeqThrow1:
  "P 1 e0,s0  throw e,s1 
  P 1 e0;;e1,s0  throw e,s1"

| CondT1:
  " P 1 e,s0  true,s1; P 1 e1,s1  e',s2 
   P 1 if (e) e1 else e2,s0  e',s2"
| CondF1:
  " P 1 e,s0  false,s1; P 1 e2,s1  e',s2 
   P 1 if (e) e1 else e2,s0  e',s2"
| CondThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 if (e) e1 else e2, s0  throw e',s1"

| WhileF1:
  "P 1 e,s0  false,s1 
  P 1 while (e) c,s0  unit,s1"
| WhileT1:
  " P 1 e,s0  true,s1; P 1 c,s1  Val v1,s2;
    P 1 while (e) c,s2  e3,s3 
   P 1 while (e) c,s0  e3,s3"
| WhileCondThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 while (e) c,s0  throw e',s1"
| WhileBodyThrow1:
  " P 1 e,s0  true,s1; P 1 c,s1  throw e',s2
   P 1 while (e) c,s0  throw e',s2"

| Throw1:
  "P 1 e,s0  addr a,s1 
  P 1 throw e,s0  Throw a,s1"
| ThrowNull1:
  "P 1 e,s0  null,s1 
  P 1 throw e,s0  THROW NullPointer,s1"
| ThrowThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 throw e,s0  throw e',s1"

| Try1:
  "P 1 e1,s0  Val v1,s1 
  P 1 try e1 catch(C i) e2,s0  Val v1,s1"
| TryCatch1:
  " P 1 e1,s0  Throw a,(h1,ls1);
    h1 a = Some(D,fs); P  D * C; i < length ls1;
    P 1 e2,(h1,ls1[i:=Addr a])  e2',(h2,ls2) 
   P 1 try e1 catch(C i) e2,s0  e2',(h2,ls2)"
| TryThrow1:
  " P 1 e1,s0  Throw a,(h1,ls1); h1 a = Some(D,fs); ¬ P  D * C 
   P 1 try e1 catch(C i) e2,s0  Throw a,(h1,ls1)"

| Nil1:
  "P 1 [],s [⇒] [],s"

| Cons1:
  " P 1 e,s0  Val v,s1; P 1 es,s1 [⇒] es',s2 
   P 1 e#es,s0 [⇒] Val v # es',s2"
| ConsThrow1:
  "P 1 e,s0  throw e',s1 
  P 1 e#es,s0 [⇒] throw e' # es, s1"

(*<*)
lemmas eval1_evals1_induct = eval1_evals1.induct [split_format (complete)]
  and eval1_evals1_inducts = eval1_evals1.inducts [split_format (complete)]
(*>*)

lemma eval1_preserves_len:
  "P 1 e0,(h0,ls0)  e1,(h1,ls1)  length ls0 = length ls1"
and evals1_preserves_len:
  "P 1 es0,(h0,ls0) [⇒] es1,(h1,ls1)  length ls0 = length ls1"
(*<*)by (induct rule:eval1_evals1_inducts, simp_all)(*>*)


lemma evals1_preserves_elen:
  "es' s s'. P 1 es,s [⇒] es',s'  length es = length es'"
(*<*)
apply(induct es type:list)
apply (auto elim:evals1.cases)
done
(*>*)


lemma eval1_final: "P 1 e,s  e',s'  final e'"
 and evals1_final: "P 1 es,s [⇒] es',s'  finals es'"
(*<*)by(induct rule:eval1_evals1.inducts, simp_all)(*>*)


end

Theory J1WellForm

(*  Title:      Jinja/Compiler/WellType1.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section ‹Well-Formedness of Intermediate Language›

theory J1WellForm
imports "../J/JWellForm" J1
begin

subsection "Well-Typedness"

type_synonym 
  env1  = "ty list"   ― ‹type environment indexed by variable number›

inductive
  WT1 :: "[J1_prog,env1, expr1     , ty     ]  bool"
         ("(_,_ 1/ _ :: _)"   [51,51,51]50)
  and WTs1 :: "[J1_prog,env1, expr1 list, ty list]  bool"
         ("(_,_ 1/ _ [::] _)" [51,51,51]50)
  for P :: J1_prog
where
  
  WTNew1:
  "is_class P C  
  P,E 1 new C :: Class C"

| WTCast1:
  " P,E 1 e :: Class D;  is_class P C;  P  C * D  P  D * C 
   P,E 1 Cast C e :: Class C"

| WTVal1:
  "typeof v = Some T 
  P,E 1 Val v :: T"

| WTVar1:
  " E!i = T; i < size E 
   P,E 1 Var i :: T"

| WTBinOp1:
  " P,E 1 e1 :: T1;  P,E 1 e2 :: T2;
     case bop of Eq  (P  T1  T2  P  T2  T1)  T = Boolean
               | Add  T1 = Integer  T2 = Integer  T = Integer 
   P,E 1 e1 «bop» e2 :: T"

| WTLAss1:
  " E!i = T;  i < size E; P,E 1 e :: T';  P  T'  T 
   P,E 1 i:=e :: Void"

| WTFAcc1:
  " P,E 1 e :: Class C;  P  C sees F:T in D 
   P,E 1 eF{D} :: T"

| WTFAss1:
  " P,E 1 e1 :: Class C;  P  C sees F:T in D;  P,E 1 e2 :: T';  P  T'  T 
   P,E 1 e1F{D} := e2 :: Void"

| WTCall1:
  " P,E 1 e :: Class C; P  C sees M:Ts'  T = m in D;
    P,E 1 es [::] Ts;  P  Ts [≤] Ts' 
   P,E 1 eM(es) :: T"

| WTBlock1:
  " is_type P T; P,E@[T] 1 e::T' 
    P,E 1 {i:T; e} :: T'"

| WTSeq1:
  " P,E 1 e1::T1;  P,E 1 e2::T2 
    P,E 1 e1;;e2 :: T2"

| WTCond1:
  " P,E 1 e :: Boolean;  P,E 1 e1::T1;  P,E 1 e2::T2;
    P  T1  T2  P  T2  T1;  P  T1  T2  T = T2; P  T2  T1  T = T1 
   P,E 1 if (e) e1 else e2 :: T"

| WTWhile1:
  " P,E 1 e :: Boolean;  P,E 1 c::T 
   P,E 1 while (e) c :: Void"

| WTThrow1:
  "P,E 1 e :: Class C  
  P,E 1 throw e :: Void"

| WTTry1:
  " P,E 1 e1 :: T;  P,E@[Class C] 1 e2 :: T; is_class P C 
   P,E 1 try e1 catch(C i) e2 :: T"

| WTNil1:
  "P,E 1 [] [::] []"

| WTCons1:
  " P,E 1 e :: T;  P,E 1 es [::] Ts 
    P,E 1 e#es [::] T#Ts"

(*<*)
declare  WT1_WTs1.intros[intro!]
declare WTNil1[iff]

lemmas WT1_WTs1_induct = WT1_WTs1.induct [split_format (complete)]
  and WT1_WTs1_inducts = WT1_WTs1.inducts [split_format (complete)]

inductive_cases eee[elim!]:
  "P,E 1 Val v :: T"
  "P,E 1 Var i :: T"
  "P,E 1 Cast D e :: T"
  "P,E 1 i:=e :: T"
  "P,E 1 {i:U; e} :: T"
  "P,E 1 e1;;e2 :: T"
  "P,E 1 if (e) e1 else e2 :: T"
  "P,E 1 while (e) c :: T"
  "P,E 1 throw e :: T"
  "P,E 1 try e1 catch(C i) e2 :: T"
  "P,E 1 eF{D} :: T"
  "P,E 1 e1F{D}:=e2 :: T"
  "P,E 1 e1 «bop» e2 :: T"
  "P,E 1 new C :: T"
  "P,E 1 eM(es) :: T"
  "P,E 1 [] [::] Ts"
  "P,E 1 e#es [::] Ts"
(*>*)

lemma WTs1_same_size: "Ts. P,E 1 es [::] Ts  size es = size Ts"
(*<*)by (induct es type:list) auto(*>*)


lemma WT1_unique:
  "P,E 1 e :: T1  (T2. P,E 1 e :: T2  T1 = T2)" and
  "P,E 1 es [::] Ts1  (Ts2. P,E 1 es [::] Ts2  Ts1 = Ts2)"
(*<*)
apply(induct rule:WT1_WTs1.inducts)
apply blast
apply blast
apply clarsimp
apply blast
apply clarsimp
apply(case_tac bop)
apply clarsimp
apply clarsimp
apply blast
apply (blast dest:sees_field_idemp sees_field_fun)
apply blast
apply (blast dest:sees_method_idemp sees_method_fun)
apply blast
apply blast
apply blast
apply blast
apply clarify
apply blast
apply blast
apply blast
done
(*>*)


lemma assumes wf: "wf_prog p P"
shows WT1_is_type: "P,E 1 e :: T  set E  types P  is_type P T"
and "P,E 1 es [::] Ts  True"
(*<*)
apply(induct rule:WT1_WTs1.inducts)
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (blast intro:nth_mem)
apply(simp split:bop.splits)
apply simp
apply (simp add:sees_field_is_type[OF _ wf])
apply simp
apply(fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply simp
apply simp
apply blast
apply simp
apply simp
apply simp
apply simp
apply simp
done
(*>*)


subsection‹Well-formedness›

― ‹Indices in blocks increase by 1›

primrec  :: "expr1  nat  bool"
  and ℬs :: "expr1 list  nat  bool" where
" (new C) i = True" |
" (Cast C e) i =  e i" |
" (Val v) i = True" |
" (e1 «bop» e2) i = ( e1 i   e2 i)" |
" (Var j) i = True" |
" (eF{D}) i =  e i" |
" (j:=e) i =  e i" |
" (e1F{D} := e2) i = ( e1 i   e2 i)" |
" (eM(es)) i = ( e i  ℬs es i)" |
" ({j:T ; e}) i = (i = j   e (i+1))" |
" (e1;;e2) i = ( e1 i   e2 i)" |
" (if (e) e1 else e2) i = ( e i   e1 i   e2 i)" |
" (throw e) i =  e i" |
" (while (e) c) i = ( e i   c i)" |
" (try e1 catch(C j) e2) i = ( e1 i  i=j   e2 (i+1))" |

"ℬs [] i = True" |
"ℬs (e#es) i = ( e i  ℬs es i)"


definition wf_J1_mdecl :: "J1_prog  cname  expr1 mdecl  bool"
where
  "wf_J1_mdecl P C    λ(M,Ts,T,body).
    (T'. P,Class C#Ts 1 body :: T'  P  T'  T) 
    𝒟 body {..size Ts} body (size Ts + 1)"

lemma wf_J1_mdecl[simp]:
  "wf_J1_mdecl P C (M,Ts,T,body) 
    ((T'. P,Class C#Ts 1 body :: T'  P  T'  T) 
     𝒟 body {..size Ts} body (size Ts + 1))"
(*<*)by (simp add:wf_J1_mdecl_def)(*>*)

abbreviation "wf_J1_prog == wf_prog wf_J1_mdecl"

end

Theory PCompiler

(*  Title:      Jinja/Compiler/PCompiler.thy

    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Program Compilation›

theory PCompiler
imports "../Common/WellForm"
begin

definition compM :: "('a  'b)  'a mdecl  'b mdecl"
where
  "compM f    λ(M, Ts, T, m). (M, Ts, T, f m)"

definition compC :: "('a  'b)  'a cdecl  'b cdecl"
where
  "compC f    λ(C,D,Fdecls,Mdecls). (C,D,Fdecls, map (compM f) Mdecls)"

definition compP :: "('a  'b)  'a prog  'b prog"
where
  "compP f    map (compC f)"

text‹Compilation preserves the program structure.  Therfore lookup
functions either commute with compilation (like method lookup) or are
preserved by it (like the subclass relation).›

lemma map_of_map4:
  "map_of (map (λ(x,a,b,c).(x,a,b,f c)) ts) =
  map_option (λ(a,b,c).(a,b,f c))  (map_of ts)"
(*<*)
apply(induct ts)
 apply simp
apply(rule ext)
apply fastforce
done
(*>*)


lemma class_compP:
  "class P C = Some (D, fs, ms)
   class (compP f P) C = Some (D, fs, map (compM f) ms)"
(*<*)by(simp add:class_def compP_def compC_def map_of_map4)(*>*)


lemma class_compPD:
  "class (compP f P) C = Some (D, fs, cms)
   ms. class P C = Some(D,fs,ms)  cms = map (compM f) ms"
(*<*)by(clarsimp simp add:class_def compP_def compC_def map_of_map4)(*>*)


lemma [simp]: "is_class (compP f P) C = is_class P C"
(*<*)by(auto simp:is_class_def dest: class_compP class_compPD)(*>*)


lemma [simp]: "class (compP f P) C = map_option (λc. snd(compC f (C,c))) (class P C)"
(*<*)
apply(simp add:compP_def compC_def class_def map_of_map4)
apply(simp add:split_def)
done
(*>*)


lemma sees_methods_compP:
  "P  C sees_methods Mm 
  compP f P  C sees_methods (map_option (λ((Ts,T,m),D). ((Ts,T,f m),D))  Mm)"
(*<*)
apply(erule Methods.induct)
 apply(rule sees_methods_Object)
  apply(erule class_compP)
 apply(rule ext)
 apply(simp add:compM_def map_of_map4 option.map_comp)
 apply(case_tac "map_of ms x")
  apply simp
 apply fastforce
apply(rule sees_methods_rec)
   apply(erule class_compP)
  apply assumption
 apply assumption
apply(rule ext)
apply(simp add:map_add_def compM_def map_of_map4 option.map_comp split:option.split)
done
(*>*)


lemma sees_method_compP:
  "P  C sees M: TsT = m in D 
  compP f P  C sees M: TsT = (f m) in D"
(*<*)by(fastforce elim:sees_methods_compP simp add:Method_def)(*>*)


lemma [simp]:
  "P  C sees M: TsT = m in D 
  method (compP f P) C M = (D,Ts,T,f m)"
(*<*)
apply(drule sees_method_compP)
apply(simp add:method_def)
apply(rule the_equality)
 apply simp
apply(fastforce dest:sees_method_fun)
done
(*>*)


lemma sees_methods_compPD:
  " cP  C sees_methods Mm'; cP = compP f P  
  Mm. P  C sees_methods Mm 
        Mm' = (map_option (λ((Ts,T,m),D). ((Ts,T,f m),D))  Mm)"
(*<*)
apply(erule Methods.induct)
 apply(clarsimp simp:compC_def)
 apply(rule exI)
 apply(rule conjI, erule sees_methods_Object)
 apply(rule refl)
 apply(rule ext)
 apply(simp add:compM_def map_of_map4 option.map_comp)
 apply(case_tac "map_of b x")
  apply simp
 apply fastforce
apply(clarsimp simp:compC_def)
apply(rule exI, rule conjI)
apply(erule (2) sees_methods_rec)
 apply(rule refl)
apply(rule ext)
apply(simp add:map_add_def compM_def map_of_map4 option.map_comp split:option.split)
done
(*>*)


lemma sees_method_compPD:
  "compP f P  C sees M: TsT = fm in D 
  m. P  C sees M: TsT = m in D  f m = fm"
(*<*)
apply(simp add:Method_def)
apply clarify
apply(drule sees_methods_compPD[OF _ refl])
apply clarsimp
apply blast
done
(*>*)


lemma [simp]: "subcls1(compP f P) = subcls1 P"
(*<*)
by(fastforce simp add: is_class_def compC_def intro:subcls1I order_antisym dest:subcls1D)
(*>*)


lemma compP_widen[simp]: "(compP f P  T  T') = (P  T  T')"
(*<*)by(cases T')(simp_all add:widen_Class)(*>*)


lemma [simp]: "(compP f P  Ts [≤] Ts') = (P  Ts [≤] Ts')"
(*<*)
apply(induct Ts)
 apply simp
apply(cases Ts')
apply(auto simp:fun_of_def)
done
(*>*)


lemma [simp]: "is_type (compP f P) T = is_type P T"
(*<*)by(cases T) simp_all(*>*)


lemma [simp]: "(compP (f::'a'b) P  C has_fields FDTs) = (P  C has_fields FDTs)"
(*<*)
 (is "?A = ?B")
proof
  { fix cP::"'b prog" assume "cP  C has_fields FDTs"
    hence "cP = compP f P  P  C has_fields FDTs"
    proof induct
      case has_fields_Object
      thus ?case by(fast intro:Fields.has_fields_Object dest:class_compPD)
    next
      case has_fields_rec
      thus ?case by(fast intro:Fields.has_fields_rec dest:class_compPD)
    qed
  } note lem = this
  assume ?A
  with lem show ?B by blast
next
  assume ?B
  thus ?A
  proof induct
    case has_fields_Object
    thus ?case by(fast intro:Fields.has_fields_Object class_compP)
  next
    case has_fields_rec
    thus ?case by(fast intro:Fields.has_fields_rec class_compP)
  qed
qed
(*>*)


lemma [simp]: "fields (compP f P) C = fields P C"
(*<*)by(simp add:fields_def)(*>*)


lemma [simp]: "(compP f P  C sees F:T in D) = (P  C sees F:T in D)"
(*<*)by(simp add:sees_field_def)(*>*)


lemma [simp]: "field (compP f P) F D = field P F D"
(*<*)by(simp add:field_def)(*>*)


subsection‹Invariance of @{term wf_prog} under compilation›

lemma [iff]: "distinct_fst (compP f P) = distinct_fst P"
(*<*)
apply(simp add:distinct_fst_def compP_def compC_def)
apply(induct P)
apply (auto simp:image_iff)
done
(*>*)


lemma [iff]: "distinct_fst (map (compM f) ms) = distinct_fst ms"
(*<*)
apply(simp add:distinct_fst_def compM_def)
apply(induct ms)
apply (auto simp:image_iff)
done
(*>*)


lemma [iff]: "wf_syscls (compP f P) = wf_syscls P"
(*<*)by(simp add:wf_syscls_def compP_def compC_def image_def Bex_def)(*>*)


lemma [iff]: "wf_fdecl (compP f P) = wf_fdecl P"
(*<*)by(simp add:wf_fdecl_def)(*>*)


lemma set_compP:
 "((C,D,fs,ms')  set(compP f P)) =
  (ms. (C,D,fs,ms)  set P  ms' = map (compM f) ms)"
(*<*)by(fastforce simp add:compP_def compC_def image_iff Bex_def)(*>*)


lemma wf_cdecl_compPI:
  " C M Ts T m. 
      wf_mdecl wf1 P C (M,Ts,T,m); P  C sees M:TsT = m in C 
      wf_mdecl wf2 (compP f P) C (M,Ts,T, f m);
    xset P. wf_cdecl wf1 P x; x  set (compP f P); wf_prog p P 
   wf_cdecl wf2 (compP f P) x"
(*<*)
apply(clarsimp simp add:wf_cdecl_def Ball_def set_compP)
apply(rename_tac C D fs ms)
apply(rule conjI)
 apply (clarsimp simp:compM_def)
 apply (drule (2) mdecl_visible)
 apply simp
apply(clarify)
apply(drule sees_method_compPD[where f = f])
apply clarsimp 
apply(fastforce simp:image_iff compM_def)
done
(*>*)


lemma wf_prog_compPI:
assumes lift: 
  "C M Ts T m. 
     P  C sees M:TsT = m in C; wf_mdecl wf1 P C (M,Ts,T,m) 
     wf_mdecl wf2 (compP f P) C (M,Ts,T, f m)"
and wf: "wf_prog wf1 P"
shows "wf_prog wf2 (compP f P)"
(*<*)
using wf
by (simp add:wf_prog_def) (blast intro:wf_cdecl_compPI lift wf)
(*>*)


end

Theory Hidden

theory Hidden
imports "List-Index.List_Index"
begin

definition hidden :: "'a list  nat  bool" where
"hidden xs i    i < size xs  xs!i  set(drop (i+1) xs)"


lemma hidden_last_index: "x  set xs  hidden (xs @ [x]) (last_index xs x)"
apply(auto simp add: hidden_def nth_append rev_nth[symmetric])
apply(drule last_index_less[OF _ le_refl])
apply simp
done

lemma hidden_inacc: "hidden xs i  last_index xs x  i"
by(auto simp add: hidden_def last_index_drop last_index_less_size_conv)


lemma [simp]: "hidden xs i  hidden (xs@[x]) i"
by(auto simp add:hidden_def nth_append)


lemma fun_upds_apply:
 "(m(xs[↦]ys)) x =
  (let xs' = take (size ys) xs
   in if x  set xs' then Some(ys ! last_index xs' x) else m x)"
apply(induct xs arbitrary: m ys)
 apply (simp add: Let_def)
apply(case_tac ys)
 apply (simp add:Let_def)
apply (simp add: Let_def last_index_Cons)
done


lemma map_upds_apply_eq_Some:
  "((m(xs[↦]ys)) x = Some y) =
  (let xs' = take (size ys) xs
   in if x  set xs' then ys ! last_index xs' x = y else m x = Some y)"
by(simp add:fun_upds_apply Let_def)


lemma map_upds_upd_conv_last_index:
  "x  set xs; size xs  size ys 
   m(xs[↦]ys)(xy) = m(xs[↦]ys[last_index xs x := y])"
apply(rule ext)
apply(simp add:fun_upds_apply eq_sym_conv Let_def)
done

end

Theory Compiler1

(*  Title:      Jinja/Compiler/Compiler1.thy
    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Compilation Stage 1›

theory Compiler1 imports PCompiler J1 Hidden begin

text‹Replacing variable names by indices.›

primrec compE1  :: "vname list  expr  expr1"
  and compEs1 :: "vname list  expr list  expr1 list" where
  "compE1 Vs (new C) = new C"
| "compE1 Vs (Cast C e) = Cast C (compE1 Vs e)"
| "compE1 Vs (Val v) = Val v"
| "compE1 Vs (e1 «bop» e2) = (compE1 Vs e1) «bop» (compE1 Vs e2)"
| "compE1 Vs (Var V) = Var(last_index Vs V)"
| "compE1 Vs (V:=e) = (last_index Vs V):= (compE1 Vs e)"
| "compE1 Vs (eF{D}) = (compE1 Vs e)F{D}"
| "compE1 Vs (e1F{D}:=e2) = (compE1 Vs e1)F{D} := (compE1 Vs e2)"
| "compE1 Vs (eM(es)) = (compE1 Vs e)M(compEs1 Vs es)"
| "compE1 Vs {V:T; e} = {(size Vs):T; compE1 (Vs@[V]) e}"
| "compE1 Vs (e1;;e2) = (compE1 Vs e1);;(compE1 Vs e2)"
| "compE1 Vs (if (e) e1 else e2) = if (compE1 Vs e) (compE1 Vs e1) else (compE1 Vs e2)"
| "compE1 Vs (while (e) c) = while (compE1 Vs e) (compE1 Vs c)"
| "compE1 Vs (throw e) = throw (compE1 Vs e)"
| "compE1 Vs (try e1 catch(C V) e2) =
    try(compE1 Vs e1) catch(C (size Vs)) (compE1 (Vs@[V]) e2)"

| "compEs1 Vs []     = []"
| "compEs1 Vs (e#es) = compE1 Vs e # compEs1 Vs es"

lemma [simp]: "compEs1 Vs es = map (compE1 Vs) es"
(*<*)by(induct es type:list) simp_all(*>*)


primrec fin1:: "expr  expr1" where
  "fin1(Val v) = Val v"
| "fin1(throw e) = throw(fin1 e)"

lemma comp_final: "final e  compE1 Vs e = fin1 e"
(*<*)by(erule finalE, simp_all)(*>*)


lemma [simp]:
      "Vs. max_vars (compE1 Vs e) = max_vars e"
and "Vs. max_varss (compEs1 Vs es) = max_varss es"
(*<*)by (induct e and es rule: max_vars.induct max_varss.induct) simp_all(*>*)


text‹Compiling programs:›

definition compP1 :: "J_prog  J1_prog"
where
  "compP1    compP (λ(pns,body). compE1 (this#pns) body)"

(*<*)
declare compP1_def[simp]
(*>*)

end

Theory Correctness1

(*  Title:      Jinja/Compiler/Correctness1.thy
    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Correctness of Stage 1›

theory Correctness1
imports J1WellForm Compiler1
begin

subsection‹Correctness of program compilation›

primrec unmod :: "expr1  nat  bool"
  and unmods :: "expr1 list  nat  bool" where
"unmod (new C) i = True" |
"unmod (Cast C e) i = unmod e i" |
"unmod (Val v) i = True" |
"unmod (e1 «bop» e2) i = (unmod e1 i  unmod e2 i)" |
"unmod (Var i) j = True" |
"unmod (i:=e) j = (i  j  unmod e j)" |
"unmod (eF{D}) i = unmod e i" |
"unmod (e1F{D}:=e2) i = (unmod e1 i  unmod e2 i)" |
"unmod (eM(es)) i = (unmod e i  unmods es i)" |
"unmod {j:T; e} i = unmod e i" |
"unmod (e1;;e2) i = (unmod e1 i   unmod e2 i)" |
"unmod (if (e) e1 else e2) i = (unmod e i  unmod e1 i  unmod e2 i)" |
"unmod (while (e) c) i = (unmod e i  unmod c i)" |
"unmod (throw e) i = unmod e i" |
"unmod (try e1 catch(C i) e2) j = (unmod e1 j  (if i=j then False else unmod e2 j))" |

"unmods ([]) i = True" |
"unmods (e#es) i = (unmod e i  unmods es i)"

lemma hidden_unmod: "Vs. hidden Vs i  unmod (compE1 Vs e) i" and
 "Vs. hidden Vs i  unmods (compEs1 Vs es) i"
(*<*)
apply(induct e and es rule: compE1.induct compEs1.induct)
apply (simp_all add:hidden_inacc)
apply(auto simp add:hidden_def)
done
(*>*)


lemma eval1_preserves_unmod:
  " P 1 e,(h,ls)  e',(h',ls'); unmod e i; i < size ls 
   ls ! i = ls' ! i"
and " P 1 es,(h,ls) [⇒] es',(h',ls'); unmods es i; i < size ls 
       ls ! i = ls' ! i"
(*<*)
apply(induct rule:eval1_evals1_inducts)
apply(auto dest!:eval1_preserves_len split:if_split_asm)
done
(*>*)


lemma LAss_lem:
  "x  set xs; size xs  size ys 
   m1 m m2(xs[↦]ys)  m1(xy) m m2(xs[↦]ys[last_index xs x := y])"
(*<*)
by(simp add:map_le_def fun_upds_apply eq_sym_conv)
(*>*)
lemma Block_lem:
fixes l :: "'a  'b"
assumes 0: "l m [Vs [↦] ls]"
    and 1: "l' m [Vs [↦] ls', Vv]"
    and hidden: "V  set Vs  ls ! last_index Vs V = ls' ! last_index Vs V"
    and size: "size ls = size ls'"    "size Vs < size ls'"
shows "l'(V := l V) m [Vs [↦] ls']"
(*<*)
proof -
  have "l'(V := l V) m [Vs [↦] ls', Vv](V := l V)"
    using 1 by(rule map_le_upd)
  also have " = [Vs [↦] ls'](V := l V)" by simp
  also have " m [Vs [↦] ls']"
  proof (cases "l V")
    case None thus ?thesis by simp
  next
    case (Some w)
    hence "[Vs [↦] ls] V = Some w"
      using 0 by(force simp add: map_le_def split:if_splits)
    hence VinVs: "V  set Vs" and w: "w = ls ! last_index Vs V"
      using size by(auto simp add:fun_upds_apply split:if_splits)
    hence "w = ls' ! last_index Vs V" using hidden[OF VinVs] by simp
    hence "[Vs [↦] ls'](V := l V) = [Vs [↦] ls']" using Some size VinVs
      by(simp add: map_upds_upd_conv_last_index)
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed
(*>*)

(*<*)
declare fun_upd_apply[simp del]
(*>*)


text‹\noindent The main theorem:›

theorem assumes wf: "wwf_J_prog P"
shows eval1_eval: "P  e,(h,l)  e',(h',l')
   (Vs ls.  fv e  set Vs;  l m [Vs[↦]ls]; size Vs + max_vars e  size ls 
        ls'. compP1 P 1 compE1 Vs e,(h,ls)  fin1 e',(h',ls')  l' m [Vs[↦]ls'])"
(*<*)
  (is "_  (Vs ls. PROP ?P e h l e' h' l' Vs ls)"
   is "_  (Vs ls.  _; _; _   ls'. ?Post e h l e' h' l' Vs ls ls')")
(*>*)

and evals1_evals: "P  es,(h,l) [⇒] es',(h',l')
     (Vs ls.  fvs es  set Vs;  l m [Vs[↦]ls]; size Vs + max_varss es  size ls 
          ls'. compP1 P 1 compEs1 Vs es,(h,ls) [⇒] compEs1 Vs es',(h',ls') 
                      l' m [Vs[↦]ls'])"
(*<*)
  (is "_  (Vs ls. PROP ?Ps es h l es' h' l' Vs ls)"
   is "_  (Vs ls.  _; _; _  ls'. ?Posts es h l es' h' l' Vs ls ls')")
proof (induct rule:eval_evals_inducts)
  case Nil thus ?case by(fastforce intro!:Nil1)
next
  case (Cons e h l v h' l' es es' h2 l2)
  have "PROP ?P e h l (Val v) h' l' Vs ls" by fact
  with Cons.prems
  obtain ls' where 1: "?Post e h l (Val v) h' l' Vs ls ls'"
    "size ls = size ls'" by(auto intro!:eval1_preserves_len)
  have "PROP ?Ps es h' l' es' h2 l2 Vs ls'" by fact
  with 1 Cons.prems
  obtain ls2 where 2: "?Posts es h' l' es' h2 l2 Vs ls' ls2" by(auto)
  from 1 2 Cons show ?case by(auto intro!:Cons1)
next
  case ConsThrow thus ?case
    by(fastforce intro!:ConsThrow1 dest: eval_final)
next
  case (Block e h l V e' h' l' T)
  let ?Vs = "Vs @ [V]"
  have IH:
  "fv e  set ?Vs; l(V := None) m [?Vs [↦] ls];
    size ?Vs + max_vars e  size ls
    ls'. compP1 P 1 compE1 ?Vs e,(h,ls)  fin1 e',(h', ls') 
             l' m [?Vs [↦] ls']" and
  fv: "fv {V:T; e}  set Vs" and rel: "l m [Vs [↦] ls]" and
  len: "length Vs + max_vars {V:T; e}  length ls" by fact+
  have len': "length Vs < length ls" using len by auto
  have "fv e  set ?Vs" using fv by auto
  moreover have "l(V := None) m [?Vs [↦] ls]" using rel len' by simp
  moreover have "size ?Vs + max_vars e  size ls" using len by simp
  ultimately obtain ls' where
   1: "compP1 P 1 compE1 ?Vs e,(h,ls)  fin1 e',(h',ls')"
   and rel': "l' m [?Vs [↦] ls']" using IH by blast
  have [simp]: "length ls = length ls'" by(rule eval1_preserves_len[OF 1])
  show "ls'. compP1 P 1 compE1 Vs {V:T; e},(h,ls)  fin1 e',(h',ls')
               l'(V := l V) m [Vs [↦] ls']" (is "ls'. ?R ls'")
  proof
    show "?R ls'"
    proof
      show "compP1 P 1 compE1 Vs {V:T; e},(h,ls)  fin1 e',(h',ls')"
        using 1 by(simp add:Block1)
    next
      show "l'(V := l V) m [Vs [↦] ls']"
      proof -
        have "l' m [Vs [↦] ls', V  ls' ! length Vs]"
          using len' rel' by simp
        moreover
        { assume VinVs: "V  set Vs"
          hence "hidden (Vs @ [V]) (last_index Vs V)"
            by(rule hidden_last_index)
          hence "unmod (compE1 (Vs @ [V]) e) (last_index Vs V)"
            by(rule hidden_unmod)
          moreover have "last_index Vs V < length ls"
            using len' VinVs by simp
          ultimately have "ls ! last_index Vs V = ls' ! last_index Vs V"
            by(rule eval1_preserves_unmod[OF 1])
        }
        ultimately show ?thesis using Block_lem[OF rel] len' by auto
      qed
    qed
  qed
next
  case (TryThrow e' h l a h' l' D fs C V e2)
  have "PROP ?P e' h l (Throw a) h' l' Vs ls" by fact
  with TryThrow.prems
  obtain ls' where 1: "?Post e' h l (Throw a) h' l' Vs ls ls'"  by(auto)
  show ?case using 1 TryThrow.hyps by(auto intro!:eval1_evals1.TryThrow1)
next
  case (TryCatch e1 h l a h1 l1 D fs C e2 V e' h2 l2)
  let ?e = "try e1 catch(C V) e2"
  have IH1: "fv e1  set Vs; l m [Vs [↦] ls];
              size Vs + max_vars e1  length ls
           ls1. compP1 P 1 compE1 Vs e1,(h,ls) 
                                fin1 (Throw a),(h1,ls1) 
                    l1 m [Vs [↦] ls1]" and
    fv: "fv ?e  set Vs" and
    rel: "l m [Vs [↦] ls]" and
    len: "length Vs + max_vars ?e  length ls" by fact+
  have "fv e1  set Vs" using fv by auto
  moreover have "length Vs + max_vars e1  length ls" using len by(auto)
  ultimately obtain ls1 where
    1: "compP1 P 1 compE1 Vs e1,(h,ls)  Throw a,(h1,ls1)"
    and rel1: "l1 m [Vs [↦] ls1]" using IH1 rel by fastforce
  from 1 have [simp]: "size ls = size ls1" by(rule eval1_preserves_len)
  let ?Vs = "Vs @ [V]" let ?ls = "(ls1[size Vs:=Addr a])"
  have IH2: "fv e2  set ?Vs; l1(V  Addr a) m [?Vs [↦] ?ls];
              length ?Vs + max_vars e2  length ?ls  ls2.
       compP1 P 1 compE1 ?Vs e2,(h1,?ls)  fin1 e',(h2, ls2) 
       l2 m [?Vs [↦] ls2]" by fact
  have len1: "size Vs < size ls1" using len by(auto)
  have "fv e2  set ?Vs" using fv by auto
  moreover have "l1(V  Addr a) m [?Vs [↦] ?ls]" using rel1 len1 by simp
  moreover have "length ?Vs + max_vars e2  length ?ls" using len by(auto)
  ultimately obtain ls2 where
    2: "compP1 P 1 compE1 ?Vs e2,(h1,?ls)  fin1 e',(h2, ls2)"
    and rel2: "l2 m [?Vs [↦] ls2]"  using IH2 by blast
  from 2 have [simp]: "size ls1 = size ls2"
    by(fastforce dest: eval1_preserves_len)
  show "ls2. compP1 P 1 compE1 Vs ?e,(h,ls)  fin1 e',(h2,ls2) 
              l2(V := l1 V) m [Vs [↦] ls2]"  (is "ls2. ?R ls2")
  proof
    show "?R ls2"
    proof
      have hp: "h1 a = Some (D, fs)" by fact
      have "P  D * C" by fact hence caught: "compP1 P  D * C" by simp
      from TryCatch1[OF 1 _ caught len1 2, OF hp]
      show "compP1 P 1 compE1 Vs ?e,(h,ls)  fin1 e',(h2,ls2)" by simp
    next
      show "l2(V := l1 V) m [Vs [↦] ls2]"
      proof -
        have "l2 m [Vs [↦] ls2, V  ls2 ! length Vs]"
          using len1 rel2 by simp
        moreover
        { assume VinVs: "V  set Vs"
          hence "hidden (Vs @ [V]) (last_index Vs V)" by(rule hidden_last_index)
          hence "unmod (compE1 (Vs @ [V]) e2) (last_index Vs V)"
            by(rule hidden_unmod)
          moreover have "last_index Vs V < length ?ls"
            using len1 VinVs by simp
          ultimately have "?ls ! last_index Vs V = ls2 ! last_index Vs V"
            by(rule eval1_preserves_unmod[OF 2])
          moreover have "last_index Vs V < size Vs" using VinVs by simp
          ultimately have "ls1 ! last_index Vs V = ls2 ! last_index Vs V"
            using len1 by(simp del:size_last_index_conv)
        }
        ultimately show ?thesis using Block_lem[OF rel1] len1  by simp
      qed
    qed
  qed
next
  case Try thus ?case by(fastforce intro!:Try1)
next
  case Throw thus ?case by(fastforce intro!:Throw1)
next
  case ThrowNull thus ?case by(fastforce intro!:ThrowNull1)
next
  case ThrowThrow thus ?case  by(fastforce intro!:ThrowThrow1)
next
  case (CondT e h l h1 l1 e1 e' h2 l2 e2)
  have "PROP ?P e h l true h1 l1 Vs ls" by fact
  with CondT.prems
  obtain ls1 where 1: "?Post e h l true h1 l1 Vs ls ls1"
    "size ls = size ls1"  by(auto intro!:eval1_preserves_len)
  have "PROP ?P e1 h1 l1 e' h2 l2 Vs ls1" by fact
  with 1 CondT.prems
  obtain ls2 where 2: "?Post e1 h1 l1 e' h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 show ?case by(auto intro!:CondT1)
next
  case (CondF e h l h1 l1 e2 e' h2 l2 e1 Vs ls)
  have "PROP ?P e h l false h1 l1 Vs ls" by fact
  with CondF.prems
  obtain ls1 where 1: "?Post e h l false h1 l1 Vs ls ls1"
    "size ls = size ls1"  by(auto intro!:eval1_preserves_len)
  have "PROP ?P e2 h1 l1 e' h2 l2 Vs ls1" by fact
  with 1 CondF.prems
  obtain ls2 where 2: "?Post e2 h1 l1 e' h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 show ?case by(auto intro!:CondF1)
next
  case CondThrow thus ?case by(fastforce intro!:CondThrow1)
next
  case (Seq e h l v h1 l1 e1 e' h2 l2)
  have "PROP ?P e h l (Val v) h1 l1 Vs ls" by fact
  with Seq.prems
  obtain ls1 where 1: "?Post e h l (Val v) h1 l1 Vs ls ls1"
    "size ls = size ls1"  by(auto intro!:eval1_preserves_len)
  have "PROP ?P e1 h1 l1 e' h2 l2 Vs ls1" by fact
  with 1 Seq.prems
  obtain ls2 where 2: "?Post e1 h1 l1 e' h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 Seq show ?case by(auto intro!:Seq1)
next
  case SeqThrow thus ?case by(fastforce intro!:SeqThrow1)
next
  case WhileF thus ?case by(fastforce intro!:eval1_evals1.intros)
next
  case (WhileT e h l h1 l1 c v h2 l2 e' h3 l3)
  have "PROP ?P e h l true h1 l1 Vs ls" by fact
  with WhileT.prems
  obtain ls1 where 1: "?Post e h l true h1 l1 Vs ls ls1"
    "size ls = size ls1"   by(auto intro!:eval1_preserves_len)
  have "PROP ?P c h1 l1 (Val v) h2 l2 Vs ls1" by fact
  with 1 WhileT.prems
  obtain ls2 where 2: "?Post c h1 l1 (Val v) h2 l2 Vs ls1 ls2"
    "size ls1 = size ls2"    by(auto intro!:eval1_preserves_len)
  have "PROP ?P (While (e) c) h2 l2 e' h3 l3 Vs ls2" by fact
  with 1 2 WhileT.prems
  obtain ls3 where 3: "?Post (While (e) c) h2 l2 e' h3 l3 Vs ls2 ls3" by(auto)
  from 1 2 3 show ?case by(auto intro!:WhileT1)
next
  case (WhileBodyThrow e h l h1 l1 c e' h2 l2)
  have "PROP ?P e h l true h1 l1 Vs ls" by fact
  with WhileBodyThrow.prems
  obtain ls1 where 1: "?Post e h l true h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?P c h1 l1 (throw e') h2 l2 Vs ls1" by fact
  with 1 WhileBodyThrow.prems
  obtain ls2 where 2: "?Post c h1 l1 (throw e') h2 l2 Vs ls1 ls2" by auto
  from 1 2 show ?case by(auto intro!:WhileBodyThrow1)
next
  case WhileCondThrow thus ?case by(fastforce intro!:WhileCondThrow1)
next
  case New thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case NewFail thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case Cast thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case CastNull thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case CastThrow thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case (CastFail e h l a h1 l1 D fs C)
  have "PROP ?P e h l (addr a) h1 l1 Vs ls" by fact
  with CastFail.prems
  obtain ls1 where 1: "?Post e h l (addr a) h1 l1 Vs ls ls1" by auto
  show ?case using 1 CastFail.hyps
    by(auto intro!:CastFail1[where D=D])
next
  case Val thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case (BinOp e h l v1 h1 l1 e1 v2 h2 l2 bop v)
  have "PROP ?P e h l (Val v1) h1 l1 Vs ls" by fact
  with BinOp.prems
  obtain ls1 where 1: "?Post e h l (Val v1) h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?P e1 h1 l1 (Val v2) h2 l2 Vs ls1" by fact
  with 1 BinOp.prems
  obtain ls2 where 2: "?Post e1 h1 l1 (Val v2) h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 BinOp show ?case by(auto intro!:BinOp1)
next
  case (BinOpThrow2 e0 h l v1 h1 l1 e1 e h2 l2 bop)
  have "PROP ?P e0 h l (Val v1) h1 l1 Vs ls" by fact
  with BinOpThrow2.prems
  obtain ls1 where 1: "?Post e0 h l (Val v1) h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?P e1 h1 l1 (throw e) h2 l2 Vs ls1" by fact
  with 1 BinOpThrow2.prems
  obtain ls2 where 2: "?Post e1 h1 l1 (throw e) h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 BinOpThrow2 show ?case by(auto intro!:BinOpThrow21)
next
  case BinOpThrow1 thus ?case  by(fastforce intro!:eval1_evals1.intros)
next
  case Var thus ?case
    by(force intro!:Var1 simp add: map_le_def fun_upds_apply)
next
  case LAss thus ?case
    by(fastforce simp add: LAss_lem intro:eval1_evals1.intros
                dest:eval1_preserves_len)
next
  case LAssThrow thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case FAcc thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case FAccNull thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case FAccThrow thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case (FAss e1 h l a h1 l1 e2 v h2 l2 C fs fs' F D h2')
  have "PROP ?P e1 h l (addr a) h1 l1 Vs ls" by fact
  with FAss.prems
  obtain ls1 where 1: "?Post e1 h l (addr a) h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?P e2 h1 l1 (Val v) h2 l2 Vs ls1" by fact
  with 1 FAss.prems
  obtain ls2 where 2: "?Post e2 h1 l1 (Val v) h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 FAss show ?case by(auto intro!:FAss1)
next
  case (FAssNull e1 h l h1 l1 e2 v h2 l2 F D)
  have "PROP ?P e1 h l null h1 l1 Vs ls" by fact
  with FAssNull.prems
  obtain ls1 where 1: "?Post e1 h l null h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?P e2 h1 l1 (Val v) h2 l2 Vs ls1" by fact
  with 1 FAssNull.prems
  obtain ls2 where 2: "?Post e2 h1 l1 (Val v) h2 l2 Vs ls1 ls2" by(auto)
  from 1 2 FAssNull show ?case by(auto intro!:FAssNull1)
next
  case FAssThrow1 thus ?case by(fastforce intro:eval1_evals1.intros)
next
  case (FAssThrow2 e1 h l v h1 l1 e2 e h2 l2 F D)
  have "PROP ?P e1 h l (Val v) h1 l1 Vs ls" by fact
  with FAssThrow2.prems
  obtain ls1 where 1: "?Post e1 h l (Val v) h1 l1 Vs ls ls1"
    "size ls = size ls1"   by(auto intro!:eval1_preserves_len)
  have "PROP ?P e2 h1 l1 (throw e) h2 l2 Vs ls1" by fact
  with 1 FAssThrow2.prems
  obtain ls2 where 2: "?Post e2 h1 l1 (throw e) h2 l2 Vs ls1 ls2"  by(auto)
  from 1 2 FAssThrow2 show ?case by(auto intro!:FAssThrow21)
next
  case (CallNull e h l h1 l1 es vs h2 l2 M)
  have "PROP ?P e h l null h1 l1 Vs ls" by fact
  with CallNull.prems
  obtain ls1 where 1: "?Post e h l null h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?Ps es h1 l1 (map Val vs) h2 l2 Vs ls1" by fact
  with 1 CallNull.prems
  obtain ls2 where 2: "?Posts es h1 l1 (map Val vs) h2 l2 Vs ls1 ls2" by(auto)
  from 1 2 CallNull show ?case
    by (auto simp add: comp_def elim!: CallNull1)
next
  case CallObjThrow thus ?case  by(fastforce intro:eval1_evals1.intros)
next
  case (CallParamsThrow e h l v h1 l1 es vs ex es' h2 l2 M)
  have "PROP ?P e h l (Val v) h1 l1 Vs ls" by fact
  with CallParamsThrow.prems
  obtain ls1 where 1: "?Post e h l (Val v) h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?Ps es h1 l1 (map Val vs @ throw ex # es') h2 l2 Vs ls1" by fact
  with 1 CallParamsThrow.prems
  obtain ls2 where 2: "?Posts es h1 l1 (map Val vs @ throw ex # es') h2 l2 Vs ls1 ls2" by(auto)
  from 1 2 CallParamsThrow show ?case
    by (auto simp add: comp_def
             elim!: CallParamsThrow1 dest!:evals_final)
next
  case (Call e h l a h1 l1 es vs h2 l2 C fs M Ts T pns body D l2' b' h3 l3)
  have "PROP ?P e h l (addr a) h1 l1 Vs ls" by fact
  with Call.prems
  obtain ls1 where 1: "?Post e h l (addr a) h1 l1 Vs ls ls1"
    "size ls = size ls1"    by(auto intro!:eval1_preserves_len)
  have "PROP ?Ps es h1 l1 (map Val vs) h2 l2 Vs ls1" by fact
  with 1 Call.prems
  obtain ls2 where 2: "?Posts es h1 l1 (map Val vs) h2 l2 Vs ls1 ls2"
    "size ls1 = size ls2"    by(auto intro!:evals1_preserves_len)
  let ?Vs = "this#pns"
  let ?ls = "Addr a # vs @ replicate (max_vars body) undefined"
  have mdecl: "P  C sees M: TsT = (pns, body) in D" by fact
  have fv_body: "fv body  set ?Vs" and wf_size: "size Ts = size pns"
    using wf mdecl by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have mdecl1: "compP1 P  C sees M: TsT = (compE1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "λ(pns,e). compE1 (this#pns) e"]
    by(simp)
  have [simp]: "l2' = [this  Addr a, pns [↦] vs]" by fact
  have Call_size: "size vs = size pns" by fact
  have "PROP ?P body h2 l2' b' h3 l3 ?Vs ?ls" by fact
  with 1 2 fv_body Call_size Call.prems
  obtain ls3 where 3: "?Post body h2 l2' b' h3 l3 ?Vs ?ls ls3"  by(auto)
  have hp: "h2 a = Some (C, fs)" by fact
  from 1 2 3 hp mdecl1 wf_size Call_size show ?case
    by(fastforce simp add: comp_def
                intro!: Call1 dest!:evals_final)
qed
(*>*)


subsection‹Preservation of well-formedness›

text‹The compiler preserves well-formedness. Is less trivial than it
may appear. We start with two simple properties: preservation of
well-typedness›

lemma compE1_pres_wt: "Vs Ts U.
   P,[Vs[↦]Ts]  e :: U; size Ts = size Vs 
   compP f P,Ts 1 compE1 Vs e :: U"
and  "Vs Ts Us.
   P,[Vs[↦]Ts]  es [::] Us; size Ts = size Vs 
   compP f P,Ts 1 compEs1 Vs es [::] Us"
(*<*)
apply(induct e and es rule: compE1.induct compEs1.induct)
apply clarsimp
apply(fastforce)
apply clarsimp
apply(fastforce split:bop.splits)
apply (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
apply (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
apply (fastforce)
apply (fastforce)
apply (fastforce dest!: sees_method_compP[where f = f])
apply (fastforce simp:nth_append)
apply (fastforce)
apply (fastforce)
apply (fastforce)
apply (fastforce)
apply (fastforce simp:nth_append)
apply simp
apply (fastforce)
done
(*>*)

text‹\noindent and the correct block numbering:›

lemma: "Vs n. size Vs = n (compE1 Vs e) n"
and ℬs: "Vs n. size Vs = n  ℬs (compEs1 Vs es) n"
(*<*)apply (induction e and es rule: ℬ.induct ℬs.induct)
                  apply (auto dest: sym)
   apply (metis length_append_singleton)
  apply (metis length_append_singleton)
  done(*>*)

text‹The main complication is preservation of definite assignment
@{term"𝒟"}.›

lemma image_last_index: "A  set(xs@[x])  last_index (xs @ [x]) ` A =
  (if x  A then insert (size xs) (last_index xs ` (A-{x})) else last_index xs ` A)"
(*<*)
by(auto simp:image_def)
(*>*)


lemma A_compE1_None[simp]:
      "Vs. 𝒜 e = None  𝒜 (compE1 Vs e) = None"
and "Vs. 𝒜s es = None  𝒜s (compEs1 Vs es) = None"
(*<*)by(induct e and es rule: compE1.induct compEs1.induct)(auto simp:hyperset_defs)(*>*)


lemma A_compE1:
      "A Vs.  𝒜 e = A; fv e  set Vs   𝒜 (compE1 Vs e) = last_index Vs ` A"
and "A Vs.  𝒜s es = A; fvs es  set Vs   𝒜s (compEs1 Vs es) = last_index Vs ` A"
(*<*)
proof(induct e and es rule: fv.induct fvs.induct)
  case (Block V' T e)
  hence "fv e  set (Vs@[V'])" by fastforce
  moreover obtain B where "𝒜 e = B"
    using Block.prems by(simp add: hyperset_defs)
  moreover from calculation have "B  set (Vs@[V'])" by(auto dest!:A_fv)
  ultimately show ?case using Block
    by(auto simp add: hyperset_defs image_last_index last_index_size_conv)
next
  case (TryCatch e1 C V' e2)
  hence fve2: "fv e2  set (Vs@[V'])" by auto
  show ?case
  proof (cases "𝒜 e1")
    assume A1: "𝒜 e1 = None"
    then obtain A2 where A2: "𝒜 e2 = A2" using TryCatch
      by(simp add:hyperset_defs)
    hence "A2  set (Vs@[V'])" using TryCatch.prems A_fv[OF A2] by simp blast
    thus ?thesis using TryCatch fve2 A1 A2
      by(auto simp add:hyperset_defs image_last_index last_index_size_conv)
  next
    fix A1 assume A1: "𝒜 e1 =  A1"
    show ?thesis
    proof (cases  "𝒜 e2")
      assume A2: "𝒜 e2 = None"
      then show ?case using TryCatch A1 by(simp add:hyperset_defs)
    next
      fix A2 assume A2: "𝒜 e2 = A2"
      have "A1  set Vs" using TryCatch.prems A_fv[OF A1] by simp blast
      moreover
      have "A2  set (Vs@[V'])" using TryCatch.prems A_fv[OF A2] by simp blast
      ultimately show ?thesis using TryCatch A1 A2
        by (auto simp add: Diff_subset_conv last_index_size_conv subsetD hyperset_defs dest!: sym [of _ A])
    qed
  qed
next
  case (Cond e e1 e2)
  { assume "𝒜 e = None  𝒜 e1 = None  𝒜 e2 = None"
    hence ?case using Cond by (auto simp add: hyperset_defs)
  }
  moreover
  { fix A A1 A2
    assume "𝒜 e = A" and A1: "𝒜 e1 = A1" and A2: "𝒜 e2 = A2"
    moreover
    have "A1  set Vs" using Cond.prems A_fv[OF A1] by simp blast
    moreover
    have "A2  set Vs" using Cond.prems A_fv[OF A2] by simp blast
    ultimately have ?case using Cond
      by(auto simp add:hyperset_defs image_Un
          inj_on_image_Int[OF inj_on_last_index])
  }
  ultimately show ?case by fastforce
qed (auto simp add:hyperset_defs)
(*>*)


lemma D_None[iff]: "𝒟 (e::'a exp) None" and [iff]: "𝒟s (es::'a exp list) None"
(*<*)by(induct e and es rule: 𝒟.induct 𝒟s.induct)(simp_all)(*>*)


lemma D_last_index_compE1:
      "A Vs.  A  set Vs; fv e  set Vs  
                𝒟 e A  𝒟 (compE1 Vs e) last_index Vs ` A"
and "A Vs.  A  set Vs; fvs es  set Vs  
                𝒟s es A  𝒟s (compEs1 Vs es) last_index Vs ` A"
(*<*)
proof(induct e and es rule: 𝒟.induct 𝒟s.induct)
  case (BinOp e1 bop e2)
  hence IH1: "𝒟 (compE1 Vs e1) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using BinOp by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = last_index Vs ` A1"
      using A_compE1[OF Some] BinOp.prems  by auto
    have "A  A1  set Vs" using BinOp.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` (A  A1)" using BinOp Some by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` A  last_index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (FAss e1 F D e2)
  hence IH1: "𝒟 (compE1 Vs e1) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using FAss by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = last_index Vs ` A1"
      using A_compE1[OF Some] FAss.prems  by auto
    have "A  A1  set Vs" using FAss.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` (A  A1)" using FAss Some by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` A  last_index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Call e1 M es)
  hence IH1: "𝒟 (compE1 Vs e1) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using Call by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = last_index Vs ` A1"
      using A_compE1[OF Some] Call.prems  by auto
    have "A  A1  set Vs" using Call.prems A_fv[OF Some] by auto
    hence "𝒟s (compEs1 Vs es) last_index Vs ` (A  A1)" using Call Some by auto
    hence "𝒟s (compEs1 Vs es) last_index Vs ` A  last_index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (TryCatch e1 C V e2)
  have " A{V}  set(Vs@[V]); fv e2  set(Vs@[V]); 𝒟 e2 A{V} 
        𝒟 (compE1 (Vs@[V]) e2) last_index (Vs@[V]) ` (A{V})" by fact
  hence "𝒟 (compE1 (Vs@[V]) e2) last_index (Vs@[V]) ` (A{V})"
    using TryCatch.prems by(simp add:Diff_subset_conv)
  moreover have "last_index (Vs@[V]) ` A  last_index Vs ` A  {size Vs}"
    using TryCatch.prems by(auto simp add: image_last_index split:if_split_asm)
  ultimately show ?case using TryCatch
    by(auto simp:hyperset_defs elim!:D_mono')
next
  case (Seq e1 e2)
  hence IH1: "𝒟 (compE1 Vs e1) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using Seq by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = last_index Vs ` A1"
      using A_compE1[OF Some] Seq.prems  by auto
    have "A  A1  set Vs" using Seq.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` (A  A1)" using Seq Some by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` A  last_index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Cond e e1 e2)
  hence IH1: "𝒟 (compE1 Vs e) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e")
    case None thus ?thesis using Cond by simp
  next
    case (Some B)
    have indexB: "𝒜 (compE1 Vs e) = last_index Vs ` B"
      using A_compE1[OF Some] Cond.prems  by auto
    have "A  B  set Vs" using Cond.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e1) last_index Vs ` (A  B)"
      and "𝒟 (compE1 Vs e2) last_index Vs ` (A  B)"
      using Cond Some by auto
    hence "𝒟 (compE1 Vs e1) last_index Vs ` A  last_index Vs ` B"
      and "𝒟 (compE1 Vs e2) last_index Vs ` A  last_index Vs ` B"
      by(simp add: image_Un)+
    thus ?thesis using IH1 indexB by auto
  qed
next
  case (While e1 e2)
  hence IH1: "𝒟 (compE1 Vs e1) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using While by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = last_index Vs ` A1"
      using A_compE1[OF Some] While.prems  by auto
    have "A  A1  set Vs" using While.prems A_fv[OF Some] by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` (A  A1)" using While Some by auto
    hence "𝒟 (compE1 Vs e2) last_index Vs ` A  last_index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Block V T e)
  have " A-{V}  set(Vs@[V]); fv e  set(Vs@[V]); 𝒟 e A-{V}  
        𝒟 (compE1 (Vs@[V]) e) last_index (Vs@[V]) ` (A-{V})" by fact
  hence "𝒟 (compE1 (Vs@[V]) e) last_index (Vs@[V]) ` (A-{V})"
    using Block.prems by(simp add:Diff_subset_conv)
  moreover have "size Vs  last_index Vs ` A"
    using Block.prems by(auto simp add:image_def size_last_index_conv)
  ultimately show ?case using Block
    by(auto simp add: image_last_index Diff_subset_conv hyperset_defs elim!: D_mono')
next
  case (Cons_exp e1 es)
  hence IH1: "𝒟 (compE1 Vs e1) last_index Vs ` A" by simp
  show ?case
  proof (cases "𝒜 e1")
    case None thus ?thesis using Cons_exp by simp
  next
    case (Some A1)
    have indexA1: "𝒜 (compE1 Vs e1) = last_index Vs ` A1"
      using A_compE1[OF Some] Cons_exp.prems  by auto
    have "A  A1  set Vs" using Cons_exp.prems A_fv[OF Some] by auto
    hence "𝒟s (compEs1 Vs es) last_index Vs ` (A  A1)" using Cons_exp Some by auto
    hence "𝒟s (compEs1 Vs es) last_index Vs ` A  last_index Vs ` A1"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
qed (simp_all add:hyperset_defs)
(*>*)


lemma last_index_image_set: "distinct xs  last_index xs ` set xs = {..<size xs}"
(*<*)by(induct xs rule:rev_induct) (auto simp add: image_last_index)(*>*)


lemma D_compE1:
  " 𝒟 e set Vs; fv e  set Vs; distinct Vs   𝒟 (compE1 Vs e) {..<length Vs}"
(*<*)by(fastforce dest!: D_last_index_compE1[OF subset_refl] simp add:last_index_image_set)(*>*)


lemma D_compE1':
assumes "𝒟 e set(V#Vs)" and "fv e  set(V#Vs)" and "distinct(V#Vs)"
shows "𝒟 (compE1 (V#Vs) e) {..length Vs}"
(*<*)
proof -
  have "{..size Vs} = {..<size(V#Vs)}" by auto
  thus ?thesis using assms by (simp only:)(rule D_compE1)
qed
(*>*)


lemma compP1_pres_wf: "wf_J_prog P  wf_J1_prog (compP1 P)"
(*<*)
apply simp
apply(rule wf_prog_compPI)
 prefer 2 apply assumption
apply(case_tac m)
apply(simp add:wf_mdecl_def wf_J1_mdecl_def wf_J_mdecl)
apply(clarify)
apply(frule WT_fv)
apply(fastforce intro!: compE1_pres_wt D_compE1' ℬ)
done
(*>*)


end

Theory Compiler2

(*  Title:      Jinja/Compiler/Compiler2.thy
    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Compilation Stage 2›

theory Compiler2
imports PCompiler J1 "../JVM/JVMExec"
begin

primrec compE2 :: "expr1  instr list"
  and compEs2 :: "expr1 list  instr list" where
  "compE2 (new C) = [New C]"
| "compE2 (Cast C e) = compE2 e @ [Checkcast C]"
| "compE2 (Val v) = [Push v]"
| "compE2 (e1 «bop» e2) = compE2 e1 @ compE2 e2 @ 
  (case bop of Eq  [CmpEq]
            | Add  [IAdd])"
| "compE2 (Var i) = [Load i]"
| "compE2 (i:=e) = compE2 e @ [Store i, Push Unit]"
| "compE2 (eF{D}) = compE2 e @ [Getfield F D]"
| "compE2 (e1F{D} := e2) =
       compE2 e1 @ compE2 e2 @ [Putfield F D, Push Unit]"
| "compE2 (eM(es)) = compE2 e @ compEs2 es @ [Invoke M (size es)]"
| "compE2 ({i:T; e}) = compE2 e"
| "compE2 (e1;;e2) = compE2 e1 @ [Pop] @ compE2 e2"
| "compE2 (if (e) e1 else e2) =
        (let cnd   = compE2 e;
             thn   = compE2 e1;
             els   = compE2 e2;
             test  = IfFalse (int(size thn + 2)); 
             thnex = Goto (int(size els + 1))
         in cnd @ [test] @ thn @ [thnex] @ els)"
| "compE2 (while (e) c) =
        (let cnd   = compE2 e;
             bdy   = compE2 c;
             test  = IfFalse (int(size bdy + 3)); 
             loop  = Goto (-int(size bdy + size cnd + 2))
         in cnd @ [test] @ bdy @ [Pop] @ [loop] @ [Push Unit])"
| "compE2 (throw e) = compE2 e @ [instr.Throw]"
| "compE2 (try e1 catch(C i) e2) =
   (let catch = compE2 e2
    in compE2 e1 @ [Goto (int(size catch)+2), Store i] @ catch)"

| "compEs2 []     = []"
| "compEs2 (e#es) = compE2 e @ compEs2 es"

text‹Compilation of exception table. Is given start address of code
to compute absolute addresses necessary in exception table.›

primrec compxE2  :: "expr1       pc  nat  ex_table"
  and compxEs2 :: "expr1 list  pc  nat  ex_table" where
  "compxE2 (new C) pc d = []"
| "compxE2 (Cast C e) pc d = compxE2 e pc d"
| "compxE2 (Val v) pc d = []"
| "compxE2 (e1 «bop» e2) pc d =
   compxE2 e1 pc d @ compxE2 e2 (pc + size(compE2 e1)) (d+1)"
| "compxE2 (Var i) pc d = []"
| "compxE2 (i:=e) pc d = compxE2 e pc d"
| "compxE2 (eF{D}) pc d = compxE2 e pc d"
| "compxE2 (e1F{D} := e2) pc d =
   compxE2 e1 pc d @ compxE2 e2 (pc + size(compE2 e1)) (d+1)"
| "compxE2 (eM(es)) pc d =
   compxE2 e pc d @ compxEs2 es (pc + size(compE2 e)) (d+1)"
| "compxE2 ({i:T; e}) pc d = compxE2 e pc d"
| "compxE2 (e1;;e2) pc d =
   compxE2 e1 pc d @ compxE2 e2 (pc+size(compE2 e1)+1) d"
| "compxE2 (if (e) e1 else e2) pc d =
        (let pc1   = pc + size(compE2 e) + 1;
             pc2   = pc1 + size(compE2 e1) + 1
         in compxE2 e pc d @ compxE2 e1 pc1 d @ compxE2 e2 pc2 d)"
| "compxE2 (while (b) e) pc d =
   compxE2 b pc d @ compxE2 e (pc+size(compE2 b)+1) d"
| "compxE2 (throw e) pc d = compxE2 e pc d"
| "compxE2 (try e1 catch(C i) e2) pc d =
   (let pc1 = pc + size(compE2 e1)
    in compxE2 e1 pc d @ compxE2 e2 (pc1+2) d @ [(pc,pc1,C,pc1+1,d)])"

| "compxEs2 [] pc d    = []"
| "compxEs2 (e#es) pc d = compxE2 e pc d @ compxEs2 es (pc+size(compE2 e)) (d+1)"

primrec max_stack :: "expr1  nat"
  and max_stacks :: "expr1 list  nat" where
  "max_stack (new C) = 1"
| "max_stack (Cast C e) = max_stack e"
| "max_stack (Val v) = 1"
| "max_stack (e1 «bop» e2) = max (max_stack e1) (max_stack e2) + 1"
| "max_stack (Var i) = 1"
| "max_stack (i:=e) = max_stack e"
| "max_stack (eF{D}) = max_stack e"
| "max_stack (e1F{D} := e2) = max (max_stack e1) (max_stack e2) + 1"
| "max_stack (eM(es)) = max (max_stack e) (max_stacks es) + 1"
| "max_stack ({i:T; e}) = max_stack e"
| "max_stack (e1;;e2) = max (max_stack e1) (max_stack e2)"
| "max_stack (if (e) e1 else e2) =
  max (max_stack e) (max (max_stack e1) (max_stack e2))"
| "max_stack (while (e) c) = max (max_stack e) (max_stack c)"
| "max_stack (throw e) = max_stack e"
| "max_stack (try e1 catch(C i) e2) = max (max_stack e1) (max_stack e2)"
 
| "max_stacks [] = 0"
| "max_stacks (e#es) = max (max_stack e) (1 + max_stacks es)"

lemma max_stack1: "1  max_stack e"
(*<*)by(induct e) (simp_all add:max_def)(*>*)


definition compMb2 :: "expr1  jvm_method"
where
  "compMb2    λbody.
  let ins = compE2 body @ [Return];
      xt = compxE2 body 0 0
  in (max_stack body, max_vars body, ins, xt)"

definition compP2 :: "J1_prog  jvm_prog"
where
  "compP2    compP compMb2"

(*<*)
declare compP2_def [simp]
(*>*)

lemma compMb2 [simp]:
  "compMb2 e = (max_stack e, max_vars e, compE2 e @ [Return], compxE2 e 0 0)"
(*<*)by (simp add: compMb2_def)(*>*)


end

Theory Correctness2

(*  Title:      Jinja/Compiler/Correctness2.thy
    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Correctness of Stage 2›

theory Correctness2
imports "HOL-Library.Sublist" Compiler2
begin

(*<*)hide_const (open) Throw(*>*)

subsection‹Instruction sequences›

text‹How to select individual instructions and subsequences of
instructions from a program given the class, method and program
counter.›

definition before :: "jvm_prog  cname  mname  nat  instr list  bool"
   ("(_,_,_,_/  _)" [51,0,0,0,51] 50) where
 "P,C,M,pc  is  prefix is (drop pc (instrs_of P C M))"

definition at :: "jvm_prog  cname  mname  nat  instr  bool"
   ("(_,_,_,_/  _)" [51,0,0,0,51] 50) where
 "P,C,M,pc  i  (is. drop pc (instrs_of P C M) = i#is)"

lemma [simp]: "P,C,M,pc  []"
(*<*)by(simp add:before_def)(*>*)


lemma [simp]: "P,C,M,pc  (i#is) = (P,C,M,pc  i  P,C,M,pc + 1  is)"
(*<*)by(fastforce simp add:before_def at_def prefix_def drop_Suc drop_tl)(*>*)

(*<*)
declare drop_drop[simp del]
(*>*)


lemma [simp]: "P,C,M,pc  (is1 @ is2) = (P,C,M,pc  is1  P,C,M,pc + size is1  is2)"
(*<*)
apply(simp add:before_def prefix_def)
apply(subst add.commute)
apply(simp add: drop_drop[symmetric])
apply fastforce
done
(*>*)

(*<*)
declare drop_drop[simp]
(*>*)


lemma [simp]: "P,C,M,pc  i  instrs_of P C M ! pc = i"
(*<*)by(clarsimp simp add:at_def strict_prefix_def nth_via_drop)(*>*)


lemma beforeM:
  "P  C sees M: TsT = body in D 
  compP2 P,D,M,0  compE2 body @ [Return]"
(*<*)
apply(drule sees_method_idemp)
apply(simp add:before_def compP2_def compMb2_def)
done
(*>*)

text‹This lemma executes a single instruction by rewriting:›

lemma [simp]:
  "P,C,M,pc  instr 
  (P  (None, h, (vs,ls,C,M,pc) # frs) -jvm→ σ') =
  ((None, h, (vs,ls,C,M,pc) # frs) = σ' 
   (σ. exec(P,(None, h, (vs,ls,C,M,pc) # frs)) = Some σ  P  σ -jvm→ σ'))"
(*<*)
apply(simp only: exec_all_def)
apply(blast intro: converse_rtranclE converse_rtrancl_into_rtrancl)
done
(*>*)


subsection‹Exception tables›

definition pcs :: "ex_table  nat set"
where
  "pcs xt    (f,t,C,h,d)  set xt. {f ..< t}"

lemma pcs_subset:
shows "pc d. pcs(compxE2 e pc d)  {pc..<pc+size(compE2 e)}"
and "pc d. pcs(compxEs2 es pc d)  {pc..<pc+size(compEs2 es)}"
(*<*)
apply(induct e and es rule: compxE2.induct compxEs2.induct)
apply (simp_all add:pcs_def)
apply (fastforce split:bop.splits)+
done
(*>*)


lemma [simp]: "pcs [] = {}"
(*<*)by(simp add:pcs_def)(*>*)


lemma [simp]: "pcs (x#xt) = {fst x ..< fst(snd x)}  pcs xt"
(*<*)by(auto simp add: pcs_def)(*>*)


lemma [simp]: "pcs(xt1 @ xt2) = pcs xt1  pcs xt2"
(*<*)by(simp add:pcs_def)(*>*)


lemma [simp]: "pc < pc0  pc0+size(compE2 e)  pc  pc  pcs(compxE2 e pc0 d)"
(*<*)using pcs_subset by fastforce(*>*)


lemma [simp]: "pc < pc0  pc0+size(compEs2 es)  pc  pc  pcs(compxEs2 es pc0 d)"
(*<*)using pcs_subset by fastforce(*>*)


lemma [simp]: "pc1 + size(compE2 e1)  pc2  pcs(compxE2 e1 pc1 d1)  pcs(compxE2 e2 pc2 d2) = {}"
(*<*)using pcs_subset by fastforce(*>*)


lemma [simp]: "pc1 + size(compE2 e)  pc2  pcs(compxE2 e pc1 d1)  pcs(compxEs2 es pc2 d2) = {}"
(*<*)using pcs_subset by fastforce(*>*)


lemma [simp]:
 "pc  pcs xt0  match_ex_table P C pc (xt0 @ xt1) = match_ex_table P C pc xt1"
(*<*)by (induct xt0) (auto simp: matches_ex_entry_def)(*>*)


lemma [simp]: " x  set xt; pc  pcs xt   ¬ matches_ex_entry P D pc x"
(*<*)by(auto simp:matches_ex_entry_def pcs_def)(*>*)


lemma [simp]:
assumes xe: "xe  set(compxE2 e pc d)" and outside: "pc' < pc  pc+size(compE2 e)  pc'"
shows "¬ matches_ex_entry P C pc' xe"
(*<*)
proof
  assume "matches_ex_entry P C pc' xe"
  with xe have "pc'  pcs(compxE2 e pc d)"
    by(force simp add:matches_ex_entry_def pcs_def)
  with outside show False by simp
qed
(*>*)


lemma [simp]:
assumes xe: "xe  set(compxEs2 es pc d)" and outside: "pc' < pc  pc+size(compEs2 es)  pc'"
shows "¬ matches_ex_entry P C pc' xe"
(*<*)
proof
  assume "matches_ex_entry P C pc' xe"
  with xe have "pc'  pcs(compxEs2 es pc d)"
    by(force simp add:matches_ex_entry_def pcs_def)
  with outside show False by simp
qed
(*>*)


lemma match_ex_table_app[simp]:
  "xte  set xt1. ¬ matches_ex_entry P D pc xte 
  match_ex_table P D pc (xt1 @ xt) = match_ex_table P D pc xt"
(*<*)by(induct xt1) simp_all(*>*)


lemma [simp]:
  "x  set xtab. ¬ matches_ex_entry P C pc x 
  match_ex_table P C pc xtab = None"
(*<*)using match_ex_table_app[where ?xt = "[]"] by fastforce(*>*)


lemma match_ex_entry:
  "matches_ex_entry P C pc (start, end, catch_type, handler) =
  (start  pc  pc < end   P  C * catch_type)"
(*<*)by(simp add:matches_ex_entry_def)(*>*)


definition caught :: "jvm_prog  pc  heap  addr  ex_table  bool" where
  "caught P pc h a xt 
  (entry  set xt. matches_ex_entry P (cname_of h a) pc entry)"

definition beforex :: "jvm_prog  cname  mname  ex_table  nat set  nat  bool"
              ("(2_,/_,/_ / _ /'/ _,/_)" [51,0,0,0,0,51] 50) where
  "P,C,M  xt / I,d 
  (xt0 xt1. ex_table_of P C M = xt0 @ xt @ xt1  pcs xt0  I = {}  pcs xt  I 
    (pc  I. C pc' d'. match_ex_table P C pc xt1 = (pc',d')  d'  d))"

definition dummyx :: "jvm_prog  cname  mname  ex_table  nat set  nat  bool"  ("(2_,_,_ / _ '/_,_)" [51,0,0,0,0,51] 50) where
  "P,C,M  xt/I,d  P,C,M  xt/I,d"

lemma beforexD1: "P,C,M  xt / I,d  pcs xt  I"
(*<*)by(auto simp add:beforex_def)(*>*)


lemma beforex_mono: " P,C,M  xt/I,d'; d'  d   P,C,M  xt/I,d"
(*<*)by(fastforce simp:beforex_def)(*>*)


lemma [simp]: "P,C,M  xt/I,d  P,C,M  xt/I,Suc d"
(*<*)by(fastforce intro:beforex_mono)(*>*)


lemma beforex_append[simp]:
  "pcs xt1  pcs xt2 = {} 
  P,C,M  xt1 @ xt2/I,d =
  (P,C,M  xt1/I-pcs xt2,d    P,C,M  xt2/I-pcs xt1,d  P,C,M  xt1@xt2/I,d)"
(*<*)
apply(rule iffI)
 prefer 2
 apply(simp add:dummyx_def)
apply(auto simp add: beforex_def dummyx_def)
 apply(rule_tac x = xt0 in exI)
 apply auto
apply(rule_tac x = "xt0@xt1" in exI)
apply auto
done
(*>*)


lemma beforex_appendD1:
  " P,C,M  xt1 @ xt2 @ [(f,t,D,h,d)] / I,d;
    pcs xt1  J; J  I; J  pcs xt2 = {} 
   P,C,M  xt1 / J,d"
(*<*)
apply(auto simp:beforex_def)
apply(rule exI,rule exI,rule conjI, rule refl)
apply(rule conjI, blast)
apply(auto)
apply(subgoal_tac "pc  pcs xt2")
 prefer 2 apply blast
apply (auto split:if_split_asm)
done
(*>*)


lemma beforex_appendD2:
  " P,C,M  xt1 @ xt2 @ [(f,t,D,h,d)] / I,d;
    pcs xt2  J; J  I; J  pcs xt1 = {} 
   P,C,M  xt2 / J,d"
(*<*)
apply(auto simp:beforex_def)
apply(rule_tac x = "xt0 @ xt1" in exI)
apply fastforce
done
(*>*)


lemma beforexM:
  "P  C sees M: TsT = body in D 
  compP2 P,D,M  compxE2 body 0 0/{..<size(compE2 body)},0"
(*<*)
apply(drule sees_method_idemp)
apply(drule sees_method_compP[where f = compMb2])
apply(simp add:beforex_def compP2_def compMb2_def)
apply(rule_tac x = "[]" in exI)
using pcs_subset apply fastforce
done
(*>*)


lemma match_ex_table_SomeD2:
 " match_ex_table P D pc (ex_table_of P C M) = (pc',d');
    P,C,M  xt/I,d; x  set xt. ¬ matches_ex_entry P D pc x; pc  I 
  d'  d"
(*<*)
apply(auto simp:beforex_def)
apply(subgoal_tac "pc  pcs xt0")
apply auto
done
(*>*)


lemma match_ex_table_SomeD1:
  " match_ex_table P D pc (ex_table_of P C M) = (pc',d');
     P,C,M  xt / I,d; pc  I; pc  pcs xt   d'  d"
(*<*)by(auto elim: match_ex_table_SomeD2)(*>*)


subsection‹The correctness proof›

(*<*)
declare nat_add_distrib[simp] caught_def[simp]
declare fun_upd_apply[simp del]
(*>*)


definition
  handle :: "jvm_prog  cname  mname  addr  heap  val list  val list  nat  frame list
                 jvm_state" where
  "handle P C M a h vs ls pc frs = find_handler P a h ((vs,ls,C,M,pc) # frs)"

lemma handle_Cons:
 " P,C,M  xt/I,d; d  size vs; pc  I;
    x  set xt. ¬ matches_ex_entry P (cname_of h xa) pc x  
  handle P C M xa h (v # vs) ls pc frs = handle P C M xa h vs ls pc frs"
(*<*)by(auto simp:handle_def Suc_diff_le dest: match_ex_table_SomeD2)(*>*)

lemma handle_append:
 " P,C,M  xt/I,d; d  size vs; pc  I; pc  pcs xt  
  handle P C M xa h (ws @ vs) ls pc frs = handle P C M xa h vs ls pc frs"
(*<*)
apply(auto simp:handle_def)
apply(rename_tac pc' d')
apply(subgoal_tac "size ws  length ws + length vs - d'")
apply(simp add:drop_all)
apply(fastforce dest:match_ex_table_SomeD2 split:nat_diff_split)
done
(*>*)


lemma aux_isin[simp]: " B  A; a  B   a  A"
(*<*)by blast(*>*)


lemma fixes P1 defines [simp]: "P  compP2 P1"
shows Jcc:
  "P1 1 e,(h0,ls0)  ef,(h1,ls1) 
  (C M pc v xa vs frs I.
      P,C,M,pc  compE2 e; P,C,M  compxE2 e pc (size vs)/I,size vs;
       {pc..<pc+size(compE2 e)}  I  
     (ef = Val v 
      P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
            (None,h1,(v#vs,ls1,C,M,pc+size(compE2 e))#frs))
     
     (ef = Throw xa 
      (pc1. pc  pc1  pc1 < pc + size(compE2 e) 
               ¬ caught P pc1 h1 xa (compxE2 e pc (size vs)) 
               P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→ handle P C M xa h1 vs ls1 pc1 frs)))"
(*<*)
  (is "_  (C M pc v xa vs frs I.
                  PROP ?P e h0 ls0 ef h1 ls1 C M pc v xa vs frs I)")
(*>*)

and "P1 1 es,(h0,ls0) [⇒] fs,(h1,ls1) 
    (C M pc ws xa es' vs frs I.
       P,C,M,pc  compEs2 es; P,C,M  compxEs2 es pc (size vs)/I,size vs;
       {pc..<pc+size(compEs2 es)}  I  
      (fs = map Val ws 
       P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(rev ws @ vs,ls1,C,M,pc+size(compEs2 es))#frs))
      
      (fs = map Val ws @ Throw xa # es' 
       (pc1. pc  pc1  pc1 < pc + size(compEs2 es) 
                ¬ caught P pc1 h1 xa (compxEs2 es pc (size vs)) 
                P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→ handle P C M xa h1 vs ls1 pc1 frs)))"
(*<*)
  (is "_  (C M pc ws xa es' vs frs I.
                  PROP ?Ps es h0 ls0 fs h1 ls1 C M pc ws xa es' vs frs I)")
proof (induct rule:eval1_evals1_inducts)
  case New1 thus ?case by (clarsimp simp add:blank_def fun_eq_iff)
next
  case NewFail1 thus ?case by(auto simp: handle_def pcs_def)
next
  case (Cast1 e h0 ls0 a h1 ls1 D fs C')
  let ?pc = "pc + length(compE2 e)"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Addr a#vs,ls1,C,M,?pc)#frs)" using Cast1 by fastforce
  also have "P   -jvm→ (None,h1,(Addr a#vs,ls1,C,M,?pc+1)#frs)"
    using Cast1 by (auto simp add:cast_ok_def)
  finally show ?case by auto
next
  case (CastNull1 e h0 ls0 h1 ls1 C')
  let ?pc = "pc + length(compE2 e)"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
            (None,h1,(Null#vs,ls1,C,M,?pc)#frs)"
    using CastNull1 by fastforce
  also have "P   -jvm→ (None,h1,(Null#vs,ls1,C,M,?pc+1)#frs)"
    using CastNull1 by (auto simp add:cast_ok_def)
  finally show ?case by auto
next
  case (CastFail1 e h0 ls0 a h1 ls1 D fs C')
  let ?pc = "pc + length(compE2 e)"
  let ?xa = "addr_of_sys_xcpt ClassCast"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Addr a#vs,ls1,C,M,?pc)#frs)"
    using CastFail1 by fastforce
  also have "P   -jvm→ handle P C M ?xa h1 (Addr a#vs) ls1 ?pc frs"
    using CastFail1 by (auto simp add:handle_def cast_ok_def)
  also have "handle P C M ?xa h1 (Addr a#vs) ls1 ?pc frs =
             handle P C M ?xa h1 vs ls1 ?pc frs"
    using CastFail1.prems by(auto simp:handle_Cons)
  finally have exec: "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→ ".
  show ?case (is "?N  (?eq  (pc1. ?H pc1))")
  proof
    show ?N by simp
  next
    have "?eq  ?H ?pc" using exec by auto
    thus "?eq  (pc1. ?H pc1)" by blast
  qed
next
  case CastThrow1 thus ?case by fastforce
next
  case Val1 thus ?case by simp
next
  case Var1 thus ?case by auto
next
  case (BinOp1 e1 h0 ls0 v1 h1 ls1 e2 v2 h2 ls2 bop w)
  let ?pc1 = "pc + length(compE2 e1)"
  let ?pc2 = "?pc1 + length(compE2 e2)"
  have IH2: "PROP ?P e2 h1 ls1 (Val v2) h2 ls2 C M ?pc1 v2 xa (v1#vs) frs
                     (I - pcs(compxE2 e1 pc (size vs)))" by fact
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(v1#vs,ls1,C,M,?pc1)#frs)" using BinOp1 by fastforce
  also have "P   -jvm→ (None,h2,(v2#v1#vs,ls2,C,M,?pc2)#frs)"
    using BinOp1.prems IH2 by fastforce
  also have "P   -jvm→ (None,h2,(w#vs,ls2,C,M,?pc2+1)#frs)"
    using BinOp1 by(cases bop) auto
  finally show ?case by (auto split: bop.splits simp:add.assoc)
next
  case BinOpThrow11 thus ?case by(fastforce)
next
  case (BinOpThrow21 e1 h0 ls0 v1 h1 ls1 e2 e h2 ls2 bop)
  let ?pc = "pc + length(compE2 e1)"
  let 1 = "(None,h1,(v1#vs,ls1,C,M,?pc)#frs)"
  have 1: "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→ 1"
    using BinOpThrow21 by fastforce
  show ?case (is "?N  (?eq  (pc2. ?H pc2))")
  proof
    show ?N by simp
  next
    { assume ?eq
      moreover
      have "PROP ?P e2 h1 ls1 (throw e) h2 ls2 C M ?pc v xa (v1#vs) frs
                     (I - pcs(compxE2 e1 pc (size vs)))" by fact
      ultimately obtain pc2 where
        pc2: "?pc  pc2  pc2 < ?pc + size(compE2 e2) 
              ¬ caught P pc2 h2 xa (compxE2 e2 ?pc (size vs + 1))" and
        2: "P  1 -jvm→ handle P C M xa h2 (v1#vs) ls2 pc2 frs"
        using BinOpThrow21.prems by fastforce
      have 3: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using 2 BinOpThrow21.prems pc2 by(auto simp:handle_Cons)
      have "?H pc2" using pc2 jvm_trans[OF 1 3] by auto
      hence "pc2. ?H pc2" by iprover
    }
    thus "?eq  (pc2. ?H pc2)" by iprover
  qed
next
  case (FAcc1 e h0 ls0 a h1 ls1 C fs F D w)
  let ?pc = "pc + length(compE2 e)"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Addr a#vs,ls1,C,M,?pc)#frs)" using FAcc1 by fastforce
  also have "P   -jvm→ (None,h1,(w#vs,ls1,C,M,?pc+1)#frs)"
    using FAcc1 by auto
  finally show ?case by auto
next
  case (FAccNull1 e h0 ls0 h1 ls1 F D)
  let ?pc = "pc + length(compE2 e)"
  let ?xa = "addr_of_sys_xcpt NullPointer"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Null#vs,ls1,C,M,?pc)#frs)" using FAccNull1 by fastforce
  also have "P   -jvm→ handle P C M ?xa h1 (Null#vs) ls1 ?pc frs"
    using FAccNull1.prems
    by(fastforce simp:split_beta handle_def simp del: split_paired_Ex)
  also have "handle P C M ?xa h1 (Null#vs) ls1 ?pc frs =
             handle P C M ?xa h1 vs ls1 ?pc frs"
    using FAccNull1.prems by(auto simp add:handle_Cons)
  finally show ?case by (auto intro: exI[where x = ?pc])
next
  case FAccThrow1 thus ?case by fastforce
next
  case (LAss1 e h0 ls0 w h1 ls1 i ls2)
  let ?pc = "pc + length(compE2 e)"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(w#vs,ls1,C,M,?pc)#frs)" using LAss1 by fastforce
  also have "P   -jvm→ (None,h1,(Unit#vs,ls2,C,M,?pc+2)#frs)"
    using LAss1 by auto
  finally show ?case using LAss1 by auto
next
  case LAssThrow1 thus ?case by fastforce
next
  case (FAss1 e1 h0 ls0 a h1 ls1 e2 w h2 ls2 C fs fs' F D h2')
  let ?pc1 = "pc + length(compE2 e1)"
  let ?pc2 = "?pc1 + length(compE2 e2)"
  have IH2: "PROP ?P e2 h1 ls1 (Val w) h2 ls2 C M ?pc1 w xa (Addr a#vs) frs
                     (I - pcs(compxE2 e1 pc (size vs)))" by fact
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Addr a#vs,ls1,C,M,?pc1)#frs)" using FAss1 by fastforce
  also have "P   -jvm→ (None,h2,(w#Addr a#vs,ls2,C,M,?pc2)#frs)"
    using FAss1.prems IH2 by fastforce
  also have "P   -jvm→ (None,h2',(Unit#vs,ls2,C,M,?pc2+2)#frs)"
    using FAss1 by auto
  finally show ?case using FAss1 by (auto simp:add.assoc)
next
  case (FAssNull1 e1 h0 ls0 h1 ls1 e2 w h2 ls2 F D)
  let ?pc1 = "pc + length(compE2 e1)"
  let ?pc2 = "?pc1 + length(compE2 e2)"
  let ?xa = "addr_of_sys_xcpt NullPointer"
  have IH2: "PROP ?P e2 h1 ls1 (Val w) h2 ls2 C M ?pc1 w xa (Null#vs) frs
                     (I - pcs(compxE2 e1 pc (size vs)))" by fact
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Null#vs,ls1,C,M,?pc1)#frs)" using FAssNull1 by fastforce
  also have "P   -jvm→ (None,h2,(w#Null#vs,ls2,C,M,?pc2)#frs)"
    using FAssNull1.prems IH2 by fastforce
  also have "P   -jvm→ handle P C M ?xa h2 (w#Null#vs) ls2 ?pc2 frs"
    using FAssNull1.prems
    by(fastforce simp:split_beta handle_def simp del: split_paired_Ex)
  also have "handle P C M ?xa h2 (w#Null#vs) ls2 ?pc2 frs =
             handle P C M ?xa h2 vs ls2 ?pc2 frs"
    using FAssNull1.prems by(auto simp add:handle_Cons)
  finally show ?case by (auto intro: exI[where x = ?pc2])
next
  case (FAssThrow21 e1 h0 ls0 w h1 ls1 e2 e' h2 ls2 F D)
  let ?pc1 = "pc + length(compE2 e1)"
  let 1 = "(None,h1,(w#vs,ls1,C,M,?pc1)#frs)"
  have 1: "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→ 1"
    using FAssThrow21 by fastforce
  show ?case (is "?N  (?eq  (pc2. ?H pc2))")
  proof
    show ?N by simp
  next
    { assume ?eq
      moreover
      have "PROP ?P e2 h1 ls1 (throw e') h2 ls2 C M ?pc1 v xa (w#vs) frs
                    (I - pcs (compxE2 e1 pc (length vs)))" by fact
      ultimately obtain pc2 where
        pc2: "?pc1  pc2  pc2 < ?pc1 + size(compE2 e2) 
              ¬ caught P pc2 h2 xa (compxE2 e2 ?pc1 (size vs + 1))" and
        2: "P  1 -jvm→ handle P C M xa h2 (w#vs) ls2 pc2 frs"
        using FAssThrow21.prems by fastforce
      have 3: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using 2 FAssThrow21.prems pc2 by(auto simp:handle_Cons)
      have "?H pc2" using pc2 jvm_trans[OF 1 3] by auto
      hence "pc2. ?H pc2" by iprover
    }
    thus "?eq  (pc2. ?H pc2)" by iprover
  qed
next
  case FAssThrow11 thus ?case by fastforce
next
  case (Call1 e h0 ls0 a h1 ls1 es pvs h2 ls2 Ca fs M' Ts T body D ls2' f h3 ls3)
  have "P1 1 es,(h1, ls1) [⇒] map Val pvs,(h2, ls2)" by fact
  hence [simp]: "length es = length pvs" by(auto dest:evals1_preserves_elen)
  let 0 = "(None,h0,(vs, ls0, C,M,pc)#frs)"
  let ?pc1 = "pc + length(compE2 e)"
  let 1 = "(None,h1,(Addr a # vs, ls1, C,M,?pc1)#frs)"
  let ?pc2 = "?pc1 + length(compEs2 es)"
  let ?frs2 = "(rev pvs @ Addr a # vs, ls2, C,M,?pc2)#frs"
  let 2 = "(None,h2,?frs2)"
  let ?frs2' = "([], ls2', D,M',0) # ?frs2"
  let 2' = "(None, h2, ?frs2')"
  have IH_es: "PROP ?Ps es h1 ls1 (map Val pvs) h2 ls2 C M ?pc1 pvs xa
                    (map Val pvs) (Addr a # vs) frs (I - pcs(compxE2 e pc (size vs)))" by fact
  have "P  0 -jvm→ 1" using Call1 by fastforce
  also have "P   -jvm→ 2" using IH_es Call1.prems by fastforce
  also have "P   -jvm→ 2'"
    using Call1 by(auto simp add: nth_append compMb2_def)
  finally have 1: "P  0 -jvm→ 2'".
  have "P1  Ca sees M': TsT = body in D" by fact
  then have M'_in_D: "P1  D sees M': TsT = body in D"
    by(rule sees_method_idemp) 
  hence M'_code: "compP2 P1,D,M',0  compE2 body @ [Return]"
    and M'_xtab: "compP2 P1,D,M'  compxE2 body 0 0/{..<size(compE2 body)},0"
    by(rule beforeM, rule beforexM)
  have IH_body: "PROP ?P body h2 ls2' f h3 ls3 D M' 0 v xa [] ?frs2 ({..<size(compE2 body)})" by fact
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note 1
      also have "P  2' -jvm→
                     (None,h3,([v],ls3,D,M',size(compE2 body))#?frs2)"
        using val IH_body Call1.prems M'_code M'_xtab
        by (fastforce simp del:split_paired_Ex)
      also have "P   -jvm→ (None, h3, (v # vs, ls2, C,M,?pc2+1)#frs)"
        using Call1 M'_code M'_in_D by(auto simp: nth_append compMb2_def)
      finally show ?trans by(simp add:add.assoc)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      assume throw: ?throw
      with IH_body obtain pc2 where
        pc2: "0  pc2  pc2 < size(compE2 body) 
              ¬ caught P pc2 h3 xa (compxE2 body 0 0)" and
        2: "P  2' -jvm→ handle P D M' xa h3 [] ls3 pc2 ?frs2"
        using Call1.prems M'_code M'_xtab
        by (fastforce simp del:split_paired_Ex)
      have "handle P D M' xa h3 [] ls3 pc2 ?frs2 =
            handle P C M xa h3 (rev pvs @ Addr a # vs) ls2 ?pc2 frs"
        using pc2 M'_in_D by(auto simp add:handle_def)
      also have " = handle P C M xa h3 vs ls2 ?pc2 frs"
        using Call1.prems by(auto simp add:handle_append handle_Cons)
      finally have "?H ?pc2" using pc2 jvm_trans[OF 1 2] by auto
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case (CallParamsThrow1 e h0 ls0 w h1 ls1 es es' h2 ls2 pvs ex es'' M')
  let 0 = "(None,h0,(vs, ls0, C,M,pc)#frs)"
  let ?pc1 = "pc + length(compE2 e)"
  let 1 = "(None,h1,(w # vs, ls1, C,M,?pc1)#frs)"
  let ?pc2 = "?pc1 + length(compEs2 es)"
  have 1: "P  0 -jvm→ 1" using CallParamsThrow1 by fastforce
  show ?case (is "?N  (?eq  (pc2. ?H pc2))")
  proof
    show ?N by simp
  next
    { assume ?eq
      moreover
      have "PROP ?Ps es h1 ls1 es' h2 ls2 C M ?pc1 pvs xa es'' (w#vs) frs
        (I - pcs (compxE2 e pc (length vs)))" by fact
      ultimately have "pc2.
        (?pc1  pc2  pc2 < ?pc1 + size(compEs2 es) 
         ¬ caught P pc2 h2 xa (compxEs2 es ?pc1 (size vs + 1))) 
        P  1 -jvm→ handle P C M xa h2 (w#vs) ls2 pc2 frs"
        (is "pc2. ?PC pc2  ?Exec pc2")
        using CallParamsThrow1 by force
      then obtain pc2 where pc2: "?PC pc2" and 2: "?Exec pc2" by iprover
      have "?H pc2" using pc2 jvm_trans[OF 1 2] CallParamsThrow1
        by(auto simp:handle_Cons)
      hence "pc2. ?H pc2" by iprover
    }
    thus "?eq  (pc2. ?H pc2)" by iprover
  qed
next
  case (CallNull1 e h0 ls0 h1 ls1 es pvs h2 ls2 M')
  have "P1 1 es,(h1, ls1) [⇒] map Val pvs,(h2, ls2)" by fact
  hence [simp]: "length es = length pvs" by(auto dest:evals1_preserves_elen)
  let ?pc1 = "pc + length(compE2 e)"
  let ?pc2 = "?pc1 + length(compEs2 es)"
  let ?xa = "addr_of_sys_xcpt NullPointer"
  have IH_es: "PROP ?Ps es h1 ls1 (map Val pvs) h2 ls2 C M ?pc1 pvs xa
                    (map Val pvs) (Null#vs) frs (I - pcs(compxE2 e pc (size vs)))" by fact
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(Null#vs,ls1,C,M,?pc1)#frs)" using CallNull1 by fastforce
  also have "P   -jvm→ (None,h2,(rev pvs@Null#vs,ls2,C,M,?pc2)#frs)"
    using CallNull1 IH_es by fastforce
  also have "P   -jvm→ handle P C M ?xa h2 (rev pvs@Null#vs) ls2 ?pc2 frs"
    using CallNull1.prems
    by(auto simp:split_beta handle_def nth_append simp del: split_paired_Ex)
  also have "handle P C M ?xa h2 (rev pvs@Null#vs) ls2 ?pc2 frs =
             handle P C M ?xa h2 vs ls2 ?pc2 frs"
    using CallNull1.prems by(auto simp:handle_Cons handle_append)
  finally show ?case by (auto intro: exI[where x = ?pc2])
next
  case CallObjThrow1 thus ?case by fastforce
next
  case Block1 thus ?case by auto
next
  case (Seq1 e1 h0 ls0 w h1 ls1 e2 e2' h2 ls2)
  let ?pc1 = "pc + length(compE2 e1)"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let 1 = "(None,h1,(vs,ls1,C,M,?pc1+1)#frs)"
  have "P  0 -jvm→ (None,h1,(w#vs,ls1,C,M,?pc1)#frs)"
    using Seq1 by fastforce
  also have "P   -jvm→ 1" using Seq1 by auto
  finally have eval1: "P  0 -jvm→ 1".
  let ?pc2 = "?pc1 + 1 + length(compE2 e2)"
  have IH2: "PROP ?P e2 h1 ls1 e2' h2 ls2 C M (?pc1+1) v xa vs frs
                     (I - pcs(compxE2 e1 pc (size vs)))" by fact
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note eval1
      also have "P  1 -jvm→ (None,h2,(v#vs,ls2,C,M,?pc2)#frs)"
        using val Seq1.prems IH2 by fastforce
      finally show ?trans by(simp add:add.assoc)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      assume throw: ?throw
      then obtain pc2 where
        pc2: "?pc1+1  pc2  pc2 < ?pc2 
              ¬ caught P pc2 h2 xa (compxE2 e2 (?pc1+1) (size vs))" and
        eval2: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using IH2 Seq1.prems by fastforce
      have "?H pc2" using pc2 jvm_trans[OF eval1 eval2] by auto
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case SeqThrow1 thus ?case by fastforce
next
  case (CondT1 e h0 ls0 h1 ls1 e1 e' h2 ls2 e2)
  let ?pc1 = "pc + length(compE2 e)"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let 1 = "(None,h1,(vs,ls1,C,M,?pc1+1)#frs)"
  have "P  0 -jvm→ (None,h1,(Bool(True)#vs,ls1,C,M,?pc1)#frs)"
    using CondT1 by (fastforce simp add: Int_Un_distrib)
  also have "P   -jvm→ 1" using CondT1 by auto
  finally have eval1: "P  0 -jvm→ 1".
  let ?pc1' = "?pc1 + 1 + length(compE2 e1)"
  let ?pc2' = "?pc1' + 1 + length(compE2 e2)"
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note eval1
      also have "P  1 -jvm→ (None,h2,(v#vs,ls2,C,M,?pc1')#frs)"
        using val CondT1 by(fastforce simp:Int_Un_distrib)
      also have "P   -jvm→ (None,h2,(v#vs,ls2,C,M,?pc2')#frs)"
        using CondT1 by(auto simp:add.assoc)
      finally show ?trans by(simp add:add.assoc)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      let ?d = "size vs"
      let ?I = "I - pcs(compxE2 e pc ?d) - pcs(compxE2 e2 (?pc1'+1) ?d)"
      assume throw: ?throw
      moreover
      have "PROP ?P e1 h1 ls1 e' h2 ls2 C M (?pc1+1) v xa vs frs ?I" by fact
      ultimately obtain pc2 where
        pc2: "?pc1+1  pc2  pc2 < ?pc1' 
              ¬ caught P pc2 h2 xa (compxE2 e1 (?pc1+1) (size vs))" and
        eval2: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using CondT1.prems by (fastforce simp:Int_Un_distrib)
      have "?H pc2" using pc2 jvm_trans[OF eval1 eval2] by auto
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case (CondF1 e h0 ls0 h1 ls1 e2 e' h2 ls2 e1)
  let ?pc1 = "pc + length(compE2 e)"
  let ?pc2 = "?pc1 + 1 + length(compE2 e1)+ 1"
  let ?pc2' = "?pc2 + length(compE2 e2)"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let 1 = "(None,h1,(vs,ls1,C,M,?pc2)#frs)"
  have "P  0 -jvm→ (None,h1,(Bool(False)#vs,ls1,C,M,?pc1)#frs)"
    using CondF1 by (fastforce simp add: Int_Un_distrib)
  also have "P   -jvm→ 1" using CondF1 by auto
  finally have eval1: "P  0 -jvm→ 1".
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note eval1
      also have "P  1 -jvm→ (None,h2,(v#vs,ls2,C,M,?pc2')#frs)"
        using val CondF1 by(fastforce simp:Int_Un_distrib)
      finally show ?trans by(simp add:add.assoc)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      let ?d = "size vs"
      let ?I = "I - pcs(compxE2 e pc ?d) - pcs(compxE2 e1 (?pc1+1) ?d)"
      assume throw: ?throw
      moreover
      have "PROP ?P e2 h1 ls1 e' h2 ls2 C M ?pc2 v xa vs frs ?I" by fact
      ultimately obtain pc2 where
        pc2: "?pc2  pc2  pc2 < ?pc2' 
              ¬ caught P pc2 h2 xa (compxE2 e2 ?pc2 ?d)" and
        eval2: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using CondF1.prems by(fastforce simp:Int_Un_distrib)
      have "?H pc2" using pc2 jvm_trans[OF eval1 eval2] by auto
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case (CondThrow1 e h0 ls0 f h1 ls1 e1 e2)
  let ?d = "size vs"
  let ?xt1 = "compxE2 e1 (pc+size(compE2 e)+1) ?d"
  let ?xt2 = "compxE2 e2 (pc+size(compE2 e)+size(compE2 e1)+2) ?d"
  let ?I = "I - (pcs ?xt1  pcs ?xt2)"
  have "pcs(compxE2 e pc ?d)  pcs(?xt1 @ ?xt2) = {}"
    using CondThrow1.prems by (simp add:Int_Un_distrib)
  moreover have "PROP ?P e h0 ls0 (throw f) h1 ls1 C M pc v xa vs frs ?I" by fact
  ultimately show ?case using CondThrow1.prems by fastforce
next
  case (WhileF1 e h0 ls0 h1 ls1 c)
  let ?pc = "pc + length(compE2 e)"
  let ?pc' = "?pc + length(compE2 c) + 3"
  have "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
            (None,h1,(Bool False#vs,ls1,C,M,?pc)#frs)"
    using WhileF1 by fastforce
  also have "P   -jvm→ (None,h1,(vs,ls1,C,M,?pc')#frs)"
    using WhileF1 by (auto simp:add.assoc)
  also have "P   -jvm→ (None,h1,(Unit#vs,ls1,C,M,?pc'+1)#frs)"
    using WhileF1.prems by (auto simp:eval_nat_numeral)
  finally show ?case by (simp add:add.assoc eval_nat_numeral)
next
  case (WhileT1 e h0 ls0 h1 ls1 c v1 h2 ls2 e3 h3 ls3)
  let ?pc = "pc + length(compE2 e)"
  let ?pc' = "?pc + length(compE2 c) + 1"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let 2 = "(None,h2,(vs,ls2,C,M,pc)#frs)"
  have "P  0 -jvm→ (None,h1,(Bool True#vs,ls1,C,M,?pc)#frs)"
    using WhileT1 by fastforce
  also have "P   -jvm→ (None,h1,(vs,ls1,C,M,?pc+1)#frs)"
    using WhileT1.prems by auto
  also have "P   -jvm→ (None,h2,(v1#vs,ls2,C,M,?pc')#frs)"
    using WhileT1 by(fastforce)
  also have "P   -jvm→ 2" using WhileT1.prems by auto
  finally have 1: "P  0 -jvm→ 2".
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note 1
      also have "P  2 -jvm→ (None,h3,(v#vs,ls3,C,M,?pc'+3)#frs)"
        using val WhileT1 by (auto simp add:add.assoc eval_nat_numeral)
      finally show ?trans by(simp add:add.assoc eval_nat_numeral)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      assume throw: ?throw
      moreover
      have "PROP ?P (while (e) c) h2 ls2 e3 h3 ls3 C M pc v xa vs frs I" by fact
      ultimately obtain pc2 where
        pc2: "pc  pc2  pc2 < ?pc'+3 
              ¬ caught P pc2 h3 xa (compxE2 (while (e) c) pc (size vs))" and
        2: "P  2 -jvm→ handle P C M xa h3 vs ls3 pc2 frs"
        using WhileT1.prems by (auto simp:add.assoc eval_nat_numeral)
      have "?H pc2" using pc2 jvm_trans[OF 1 2] by auto
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case WhileCondThrow1 thus ?case by fastforce
next
  case (WhileBodyThrow1 e h0 ls0 h1 ls1 c e' h2 ls2)
  let ?pc1 = "pc + length(compE2 e)"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let 1 = "(None,h1,(vs,ls1,C,M,?pc1+1)#frs)"
  have "P  0 -jvm→ (None,h1,(Bool(True)#vs,ls1,C,M,?pc1)#frs)"
    using WhileBodyThrow1 by (fastforce simp add: Int_Un_distrib)
  also have "P   -jvm→ 1" using  WhileBodyThrow1 by auto
  finally have eval1: "P  0 -jvm→ 1".
  let ?pc1' = "?pc1 + 1 + length(compE2 c)"
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm by simp
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      assume throw: ?throw
      moreover
      have "PROP ?P c h1 ls1 (throw e') h2 ls2 C M (?pc1+1) v xa vs frs
                    (I - pcs (compxE2 e pc (size vs)))" by fact
      ultimately obtain pc2 where
        pc2: "?pc1+1  pc2  pc2 < ?pc1' 
              ¬ caught P pc2 h2 xa (compxE2 c (?pc1+1) (size vs))" and
        eval2: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using WhileBodyThrow1.prems by (fastforce simp:Int_Un_distrib)
      have "?H pc2" using pc2 jvm_trans[OF eval1 eval2] by auto
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case (Throw1 e h0 ls0 a h1 ls1)
  let ?pc = "pc + size(compE2 e)"
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm by simp
  next
    show ?Err (is "?throw  (pc1. ?H pc1)")
    proof
      assume ?throw
      hence "P  (None, h0, (vs, ls0, C, M, pc) # frs) -jvm→
                 (None, h1, (Addr xa#vs, ls1, C, M, ?pc) # frs)"
        using Throw1 by fastforce
      also have "P   -jvm→ handle P C M xa h1 (Addr xa#vs) ls1 ?pc frs"
        using Throw1.prems by(auto simp add:handle_def)
      also have "handle P C M xa h1 (Addr xa#vs) ls1 ?pc frs =
                 handle P C M xa h1 vs ls1 ?pc frs"
        using Throw1.prems by(auto simp add:handle_Cons)
      finally have "?H ?pc" by simp
      thus "pc1. ?H pc1" by iprover
    qed
  qed
next
  case (ThrowNull1 e h0 ls0 h1 ls1)
  let ?pc = "pc + size(compE2 e)"
  let ?xa = "addr_of_sys_xcpt NullPointer"
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm by simp
  next
    show ?Err (is "?throw  (pc1. ?H pc1)")
    proof
      assume throw: ?throw
      have "P  (None, h0, (vs, ls0, C, M, pc) # frs) -jvm→
                 (None, h1, (Null#vs, ls1, C, M, ?pc) # frs)"
        using ThrowNull1 by fastforce
      also have "P   -jvm→  handle P C M ?xa h1 (Null#vs) ls1 ?pc frs"
        using ThrowNull1.prems by(auto simp add:handle_def)
      also have "handle P C M ?xa h1 (Null#vs) ls1 ?pc frs =
                 handle P C M ?xa h1 vs ls1 ?pc frs"
        using ThrowNull1.prems by(auto simp add:handle_Cons)
      finally have "?H ?pc" using throw by simp
      thus "pc1. ?H pc1" by iprover
    qed
  qed
next
  case ThrowThrow1 thus ?case by fastforce
next
  case (Try1 e1 h0 ls0 v1 h1 ls1 Ci i e2)
  let ?pc1 = "pc + length(compE2 e1)"
  let ?pc1' = "?pc1 + 2 + length(compE2 e2)"
  have "P,C,M  compxE2 (try e1 catch(Ci i) e2) pc (size vs) / I,size vs" by fact
  hence "P,C,M  compxE2 e1 pc (size vs) /
                 {pc..<pc + length (compE2 e1)},size vs"
    using Try1.prems by (fastforce simp:beforex_def split:if_split_asm)
  hence "P  (None,h0,(vs,ls0,C,M,pc)#frs) -jvm→
             (None,h1,(v1#vs,ls1,C,M,?pc1)#frs)" using Try1 by auto
  also have "P   -jvm→ (None,h1,(v1#vs,ls1,C,M,?pc1')#frs)"
    using Try1.prems by auto
  finally show ?case by (auto simp:add.assoc)
next
  case (TryCatch1 e1 h0 ls0 a h1 ls1 D fs Ci i e2 e2' h2 ls2)
  let ?e = "try e1 catch(Ci i) e2"
  let ?xt = "compxE2 ?e pc (size vs)"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let ?ls1 = "ls1[i := Addr a]"
  let ?pc1 = "pc + length(compE2 e1)"
  let ?pc1' = "?pc1 + 2"
  let 1 = "(None,h1,(vs,?ls1,C,M, ?pc1') # frs)"
  have I: "{pc..<pc + length (compE2 (try e1 catch(Ci i) e2))}  I"
   and beforex: "P,C,M  ?xt/I,size vs" by fact+
  have "P  0 -jvm→ (None,h1,((Addr a)#vs,ls1,C,M, ?pc1+1) # frs)"
  proof -
    have "PROP ?P e1 h0 ls0 (Throw a) h1 ls1 C M pc w a vs frs {pc..<pc + length (compE2 e1)}"
      by fact
    moreover have "P,C,M  compxE2 e1 pc (size vs)/{pc..<?pc1},size vs"
      using beforex I pcs_subset by(force elim!: beforex_appendD1)
    ultimately have
      "pc1. pc  pc1  pc1 < ?pc1 
             ¬ caught P pc1 h1 a (compxE2 e1 pc (size vs)) 
             P  0 -jvm→ handle P C M a h1 vs ls1 pc1 frs"
      using  TryCatch1.prems by auto
    then obtain pc1 where
      pc1_in_e1: "pc  pc1" "pc1 < ?pc1" and
      pc1_not_caught: "¬ caught P pc1 h1 a (compxE2 e1 pc (size vs))" and
      0: "P  0 -jvm→ handle P C M a h1 vs ls1 pc1 frs" by iprover
    from beforex obtain xt0 xt1
      where ex_tab: "ex_table_of P C M = xt0 @ ?xt @ xt1"
      and disj: "pcs xt0  I = {}" by(auto simp:beforex_def)
    have hp: "h1 a = Some (D, fs)" "P1  D * Ci" by fact+
    have "pc1  pcs xt0" using pc1_in_e1 I disj by auto
    with pc1_in_e1 pc1_not_caught hp
    show ?thesis using ex_tab 0 by(simp add:handle_def matches_ex_entry_def)
  qed
  also have "P   -jvm→ 1" using TryCatch1 by auto
  finally have 1: "P  0 -jvm→ 1" .
  let ?pc2 = "?pc1' + length(compE2 e2)"
  let ?I2 = "{?pc1' ..< ?pc2}"
  have "P,C,M  compxE2 ?e pc (size vs) / I,size vs" by fact
  hence beforex2: "P,C,M  compxE2 e2 ?pc1' (size vs) / ?I2, size vs"
    using I pcs_subset[of _ ?pc1'] by(auto elim!:beforex_appendD2)
  have IH2: "PROP ?P e2 h1 ?ls1 e2' h2 ls2 C M ?pc1' v xa vs frs ?I2" by fact
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note 1 also have "P  1 -jvm→ (None,h2,(v#vs,ls2,C,M,?pc2)#frs)"
        using val beforex2 IH2 TryCatch1.prems by auto
      finally show ?trans by(simp add:add.assoc)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      assume throw: ?throw
      then obtain pc2 where
        pc2: "?pc1+2  pc2  pc2 < ?pc2 
              ¬ caught P pc2 h2 xa (compxE2 e2 ?pc1' (size vs))" and
        2: "P  1 -jvm→ handle P C M xa h2 vs ls2 pc2 frs"
        using IH2 beforex2 TryCatch1.prems by auto
      have "?H pc2" using pc2 jvm_trans[OF 1 2]
        by (simp add:match_ex_entry) (fastforce)
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case (TryThrow1 e1 h0 ls0 a h1 ls1 D fs Ci i e2)
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let ?pc1 = "pc + length(compE2 e1)"
  let ?e = "try e1 catch(Ci i) e2"
  let ?xt = "compxE2 ?e pc (size vs)"
  have I: "{pc..<pc + length (compE2 (try e1 catch(Ci i) e2))}  I"
   and beforex: "P,C,M  ?xt/I,size vs" by fact+
  have "PROP ?P e1 h0 ls0 (Throw a) h1 ls1 C M pc w a vs frs {pc..<pc + length (compE2 e1)}" by fact
  moreover have "P,C,M  compxE2 e1 pc (size vs)/{pc..<?pc1},size vs"
    using beforex I pcs_subset by(force elim!: beforex_appendD1)
    ultimately have
      "pc1. pc  pc1  pc1 < ?pc1 
             ¬ caught P pc1 h1 a (compxE2 e1 pc (size vs)) 
             P  0 -jvm→ handle P C M a h1 vs ls1 pc1 frs"
      using TryThrow1.prems by auto
    then obtain pc1 where
      pc1_in_e1: "pc  pc1" "pc1 < ?pc1" and
      pc1_not_caught: "¬ caught P pc1 h1 a (compxE2 e1 pc (size vs))" and
      0: "P  0 -jvm→ handle P C M a h1 vs ls1 pc1 frs" by iprover
  show ?case (is "?N  (?eq  (pc2. ?H pc2))")
  proof
    show ?N by simp
  next
    { assume ?eq
      with TryThrow1 pc1_in_e1 pc1_not_caught 0
      have "?H pc1" by (simp add:match_ex_entry) auto
      hence "pc2. ?H pc2" by iprover
    }
    thus "?eq  (pc2. ?H pc2)" by iprover
  qed
next
  case Nil1 thus ?case by simp
next
  case (Cons1 e h0 ls0 v h1 ls1 es fs h2 ls2)
  let ?pc1 = "pc + length(compE2 e)"
  let 0 = "(None,h0,(vs,ls0,C,M,pc)#frs)"
  let 1 = "(None,h1,(v#vs,ls1,C,M,?pc1)#frs)"
  have 1: "P  0 -jvm→ 1" using Cons1 by fastforce
  let ?pc2 = "?pc1 + length(compEs2 es)"
  have IHs: "PROP ?Ps es h1 ls1 fs h2 ls2 C M ?pc1 (tl ws) xa es' (v#vs) frs
    (I - pcs (compxE2 e pc (length vs)))" by fact
  show ?case (is "?Norm  ?Err")
  proof
    show ?Norm (is "?val  ?trans")
    proof
      assume val: ?val
      note 1
      also have "P  1 -jvm→ (None,h2,(rev(ws) @ vs,ls2,C,M,?pc2)#frs)"
        using val IHs Cons1.prems by fastforce
      finally show ?trans by(simp add:add.assoc)
    qed
  next
    show ?Err (is "?throw  (pc2. ?H pc2)")
    proof
      assume throw: ?throw
      then obtain pc2 where
        pc2: "?pc1  pc2  pc2 < ?pc2 
              ¬ caught P pc2 h2 xa (compxEs2 es ?pc1 (size vs + 1))" and
        2: "P  1 -jvm→ handle P C M xa h2 (v#vs) ls2 pc2 frs"
        using IHs Cons1.prems
        by(fastforce simp:Cons_eq_append_conv neq_Nil_conv)
      have "?H pc2" using Cons1.prems pc2 jvm_trans[OF 1 2]
        by (auto simp add: handle_Cons)
      thus "pc2. ?H pc2" by iprover
    qed
  qed
next
  case ConsThrow1 thus ?case by (fastforce simp:Cons_eq_append_conv)
qed
(*>*)


(*FIXME move! *)
lemma atLeast0AtMost[simp]: "{0::nat..n} = {..n}"
by auto

lemma atLeast0LessThan[simp]: "{0::nat..<n} = {..<n}"
by auto

fun exception :: "'a exp  addr option" where
  "exception (Throw a) = Some a"
| "exception e = None"


lemma comp2_correct:
assumes "method": "P1  C sees M:TsT = body in C"
    and eval:   "P1 1 body,(h,ls)  e',(h',ls')"
shows "compP2 P1  (None,h,[([],ls,C,M,0)]) -jvm→ (exception e',h',[])"
(*<*)
      (is "_  0 -jvm→ 1")
proof -
  let ?P = "compP2 P1"
  have code: "?P,C,M,0  compE2 body" using beforeM[OF "method"] by auto
  have xtab: "?P,C,M  compxE2 body 0 (size[])/{..<size(compE2 body)},size[]"
    using beforexM[OF "method"] by auto
  ― ‹Distinguish if e' is a value or an exception›
  { fix v assume [simp]: "e' = Val v"
    have "?P  0 -jvm→ (None,h',[([v],ls',C,M,size(compE2 body))])"
      using Jcc[OF eval code xtab] by auto
    also have "?P   -jvm→ 1" using beforeM[OF "method"] by auto
    finally have ?thesis .
  }
  moreover
  { fix a assume [simp]: "e' = Throw a"
    obtain pc where pc: "0  pc  pc < size(compE2 body) 
          ¬ caught ?P pc h' a (compxE2 body 0 0)"
    and 1: "?P  0 -jvm→ handle ?P C M a h' [] ls' pc []"
      using Jcc[OF eval code xtab] by fastforce
    from pc have "handle ?P C M a h' [] ls' pc [] = 1" using xtab "method"
      by(auto simp:handle_def compMb2_def)
    with 1 have ?thesis by simp
  } 
  ultimately show ?thesis using eval1_final[OF eval] by(auto simp:final_def)
qed
(*>*)

end

Theory Compiler

(*  Title:      Jinja/Compiler/Compiler.thy

    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Combining Stages 1 and 2›

theory Compiler
imports Correctness1 Correctness2
begin

definition J2JVM :: "J_prog  jvm_prog"
where 
  "J2JVM    compP2  compP1"

theorem comp_correct:
assumes wwf: "wwf_J_prog P"
and "method": "P  C sees M:TsT = (pns,body) in C"
and eval: "P  body,(h,[this#pns [↦] vs])  e',(h',l')"
and sizes: "size vs = size pns + 1"    "size rest = max_vars body"
shows "J2JVM P  (None,h,[([],vs@rest,C,M,0)]) -jvm→ (exception e',h',[])"
(*<*)
proof -
  let ?P1 = "compP1 P"
  have fv: "fv body  set (this#pns)"
    using wwf "method" by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have init: "[this#pns [↦] vs] m [this#pns [↦] vs@rest]"
    using sizes by simp
  have "?P1  C sees M: TsT = (compE1 (this#pns) body) in C"
    using sees_method_compP[OF "method", of "λ(pns,e). compE1 (this#pns) e"]
    by(simp)
  moreover obtain ls' where
    "?P1 1 compE1 (this#pns) body, (h, vs@rest)  fin1 e', (h',ls')"
    using eval1_eval[OF wwf eval fv init] sizes by auto
  ultimately show ?thesis using comp2_correct eval_final[OF eval]
    by(fastforce simp add:J2JVM_def final_def)
qed
(*>*)


end

Theory TypeComp

(*  Title:      Jinja/Compiler/TypeComp.thy

    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section ‹Preservation of Well-Typedness›

theory TypeComp
imports Compiler "../BV/BVSpec"
begin

(*<*)
declare nth_append[simp]
(*>*)

locale TC0 =
  fixes P :: "J1_prog" and mxl :: nat
begin

definition "ty E e = (THE T. P,E 1 e :: T)"

definition "tyl E A' = map (λi. if i  A'  i < size E then OK(E!i) else Err) [0..<mxl]"

definition "tyi' ST E A = (case A of None  None | A'  Some(ST, tyl E A'))"

definition "after E A ST e = tyi' (ty E e # ST) E (A  𝒜 e)"

end

lemma (in TC0) ty_def2 [simp]: "P,E 1 e :: T  ty E e = T"
(*<*)
apply (unfold ty_def)
apply(blast intro: the_equality WT1_unique)
done
(*>*)

lemma (in TC0) [simp]: "tyi' ST E None = None"
(*<*)by (simp add: tyi'_def)(*>*)

lemma (in TC0) tyl_app_diff[simp]:
 "tyl (E@[T]) (A - {size E}) = tyl E A"
(*<*)by(auto simp add:tyl_def hyperset_defs)(*>*)


lemma (in TC0) tyi'_app_diff[simp]:
 "tyi' ST (E @ [T]) (A  size E) = tyi' ST E A"
(*<*)by(auto simp add:tyi'_def hyperset_defs)(*>*)


lemma (in TC0) tyl_antimono:
 "A  A'  P  tyl E A' [≤] tyl E A"
(*<*)by(auto simp:tyl_def list_all2_conv_all_nth)(*>*)


lemma (in TC0) tyi'_antimono:
 "A  A'  P  tyi' ST E A' ≤' tyi' ST E A"
(*<*)by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth)(*>*)


lemma (in TC0) tyl_env_antimono:
 "P  tyl (E@[T]) A [≤] tyl E A" 
(*<*)by(auto simp:tyl_def list_all2_conv_all_nth)(*>*)


lemma (in TC0) tyi'_env_antimono:
 "P  tyi' ST (E@[T]) A ≤' tyi' ST E A" 
(*<*)by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth)(*>*)


lemma (in TC0) tyi'_incr:
 "P  tyi' ST (E @ [T]) insert (size E) A ≤' tyi' ST E A"
(*<*)by(auto simp:tyi'_def tyl_def list_all2_conv_all_nth)(*>*)


lemma (in TC0) tyl_incr:
 "P  tyl (E @ [T]) (insert (size E) A) [≤] tyl E A"
(*<*)by(auto simp: hyperset_defs tyl_def list_all2_conv_all_nth)(*>*)


lemma (in TC0) tyl_in_types:
 "set E  types P  tyl E A  list mxl (err (types P))"
(*<*)by(auto simp add:tyl_def intro!:listI dest!: nth_mem)(*>*)

locale TC1 = TC0
begin

primrec compT :: "ty list  nat hyperset  ty list  expr1  tyi' list" and
   compTs :: "ty list  nat hyperset  ty list  expr1 list  tyi' list" where
"compT E A ST (new C) = []"
| "compT E A ST (Cast C e) =  
   compT E A ST e @ [after E A ST e]"
| "compT E A ST (Val v) = []"
| "compT E A ST (e1 «bop» e2) =
  (let ST1 = ty E e1#ST; A1 = A  𝒜 e1 in
   compT E A ST e1 @ [after E A ST e1] @
   compT E A1 ST1 e2 @ [after E A1 ST1 e2])"
| "compT E A ST (Var i) = []"
| "compT E A ST (i := e) = compT E A ST e @
   [after E A ST e, tyi' ST E (A  𝒜 e  {i})]"
| "compT E A ST (eF{D}) = 
   compT E A ST e @ [after E A ST e]"
| "compT E A ST (e1F{D} := e2) =
  (let ST1 = ty   E e1#ST; A1 = A  𝒜 e1; A2 = A1  𝒜 e2 in
   compT E A ST e1 @ [after E A ST e1] @
   compT E A1 ST1 e2 @ [after E A1 ST1 e2] @
   [tyi' ST E A2])"
| "compT E A ST {i:T; e} = compT (E@[T]) (Ai) ST e"
| "compT E A ST (e1;;e2) =
  (let A1 = A  𝒜 e1 in
   compT E A ST e1 @ [after E A ST e1, tyi' ST E A1] @
   compT E A1 ST e2)"
| "compT E A ST (if (e) e1 else e2) =
   (let A0 = A  𝒜 e; τ = tyi' ST E A0 in
    compT E A ST e @ [after E A ST e, τ] @
    compT E A0 ST e1 @ [after E A0 ST e1, τ] @
    compT E A0 ST e2)"
| "compT E A ST (while (e) c) =
   (let A0 = A  𝒜 e;  A1 = A0  𝒜 c; τ = tyi' ST E A0 in
    compT E A ST e @ [after E A ST e, τ] @
    compT E A0 ST c @ [after E A0 ST c, tyi' ST E A1, tyi' ST E A0])"
| "compT E A ST (throw e) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (eM(es)) =
   compT E A ST e @ [after E A ST e] @
   compTs E (A  𝒜 e) (ty   E e # ST) es"
| "compT E A ST (try e1 catch(C i) e2) =
   compT E A ST e1 @ [after E A ST e1] @
   [tyi' (Class C#ST) E A, tyi' ST (E@[Class C]) (A  {i})] @
   compT (E@[Class C]) (A  {i}) ST e2"
| "compTs E A ST [] = []"
| "compTs  E A ST (e#es) = compT E A ST e @ [after E A ST e] @
                            compTs E (A  (𝒜 e)) (ty E e # ST) es"

definition compTa :: "ty list  nat hyperset  ty list  expr1  tyi' list" where
  "compTa E A ST e = compT E A ST e @ [after E A ST e]"

end

lemma compE2_not_Nil[simp]: "compE2 e  []"
(*<*)by(induct e) auto(*>*)

lemma (in TC1) compT_sizes[simp]:
shows "E A ST. size(compT E A ST e) = size(compE2 e) - 1"
and "E A ST. size(compTs E A ST es) = size(compEs2 es)"
(*<*)
apply(induct e and es rule: compE2.induct compEs2.induct)
apply(auto split:bop.splits nat_diff_split)
done
(*>*)


lemma (in TC1) [simp]: "ST E. τ  set (compT E None ST e)"
and [simp]: "ST E. τ  set (compTs E None ST es)"
(*<*)by(induct e and es rule: compT.induct compTs.induct) (simp_all add:after_def)(*>*)


lemma (in TC0) pair_eq_tyi'_conv:
  "((ST, LT) = tyi' ST0 E A) =
  (case A of None  False | Some A  (ST = ST0  LT = tyl E A))"
(*<*)by(simp add:tyi'_def)(*>*)


lemma (in TC0) pair_conv_tyi':
  "(ST, tyl E A) = tyi' ST E A"
(*<*)by(simp add:tyi'_def)(*>*)

(*<*)
declare (in TC0)
  tyi'_antimono [intro!] after_def[simp]
  pair_conv_tyi'[simp] pair_eq_tyi'_conv[simp]
(*>*)


lemma (in TC1) compT_LT_prefix:
 "E A ST0.  (ST,LT)  set(compT E A ST0 e);e (size E) 
                P  (ST,LT) ≤' tyi' ST E A"
and
 "E A ST0.  (ST,LT)  set(compTs E A ST0 es); ℬs es (size E) 
                P  (ST,LT) ≤' tyi' ST E A"
(*<*)
proof(induct e and es rule: compT.induct compTs.induct)
  case FAss thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case BinOp thus ?case
    by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans split:bop.splits)
next
  case Seq thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case While thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case Cond thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case Block thus ?case
    by(force simp add:hyperset_defs tyi'_def simp del:pair_conv_tyi'
             elim!:sup_state_opt_trans)
next
  case Call thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case Cons_exp thus ?case
    by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
  case TryCatch thus ?case
    by(fastforce simp:hyperset_defs intro!:(* tyi'_env_antimono *) tyi'_incr
                elim!:sup_state_opt_trans)
qed (auto simp:hyperset_defs)

declare (in TC0)
  tyi'_antimono [rule del] after_def[simp del]
  pair_conv_tyi'[simp del] pair_eq_tyi'_conv[simp del]
(*>*)


lemma [iff]: "OK None  states P mxs mxl"
(*<*)by(simp add: JVM_states_unfold)(*>*)

lemma (in TC0) after_in_states:
 " wf_prog p P; P,E 1 e :: T; set E  types P; set ST  types P;
    size ST + max_stack e  mxs 
  OK (after E A ST e)  states P mxs mxl"
(*<*)
apply(subgoal_tac "size ST + 1  mxs")
 apply(simp add: after_def tyi'_def JVM_states_unfold tyl_in_types)
 apply(blast intro!:listI WT1_is_type)
using max_stack1[of e] apply simp
done
(*>*)


lemma (in TC0) OK_tyi'_in_statesI[simp]:
  " set E  types P; set ST  types P; size ST  mxs 
   OK (tyi' ST E A)  states P mxs mxl"
(*<*)
apply(simp add:tyi'_def JVM_states_unfold tyl_in_types)
apply(blast intro!:listI)
done
(*>*)


lemma is_class_type_aux: "is_class P C  is_type P (Class C)"
(*<*)by(simp)(*>*)

(*<*)
declare is_type_simps[simp del] subsetI[rule del]
(*>*)

theorem (in TC1) compT_states:
assumes wf: "wf_prog p P"
shows "E T A ST.
   P,E 1 e :: T; set E  types P; set ST  types P;
    size ST + max_stack e  mxs; size E + max_vars e  mxl 
   OK ` set(compT E A ST e)  states P mxs mxl"
(*<*)(is "E T A ST. PROP ?P e E T A ST")(*>*)

and "E Ts A ST.
   P,E 1 es[::]Ts;  set E  types P; set ST  types P;
    size ST + max_stacks es  mxs; size E + max_varss es  mxl 
   OK ` set(compTs E A ST es)  states P mxs mxl"
(*<*)(is "E Ts A ST. PROP ?Ps es E Ts A ST")
proof(induct e and es rule: compT.induct compTs.induct)
  case new thus ?case by(simp)
next
  case (Cast C e) thus ?case by (auto simp:after_in_states[OF wf])
next
  case Val thus  ?case by(simp)
next
  case Var thus ?case by(simp)
next
  case LAss thus ?case  by(auto simp:after_in_states[OF wf])
next
  case FAcc thus ?case by(auto simp:after_in_states[OF wf])
next
  case FAss thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf] after_in_states[OF wf])
next
  case Seq thus ?case
    by(auto simp:image_Un after_in_states[OF wf])
next
  case BinOp thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf] after_in_states[OF wf])
next
  case Cond thus ?case
    by(force simp:image_Un WT1_is_type[OF wf] after_in_states[OF wf])
next
  case While thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf] after_in_states[OF wf])
next
  case Block thus ?case by(auto)
next
  case (TryCatch e1 C i e2)
  moreover have "size ST + 1  mxs" using TryCatch.prems max_stack1[of e1] by auto
  ultimately show ?case  
    by(auto simp:image_Un WT1_is_type[OF wf] after_in_states[OF wf]
                  is_class_type_aux)
next
  case Nil_exp thus ?case by simp
next
  case Cons_exp thus ?case
    by(auto simp:image_Un  WT1_is_type[OF wf] after_in_states[OF wf])
next
  case throw thus ?case
    by(auto simp: WT1_is_type[OF wf] after_in_states[OF wf])
next
  case Call thus ?case
    by(auto simp:image_Un WT1_is_type[OF wf] after_in_states[OF wf])
qed

declare is_type_simps[simp] subsetI[intro!]
(*>*)


definition shift :: "nat  ex_table  ex_table"
where
  "shift n xt  map (λ(from,to,C,handler,depth). (from+n,to+n,C,handler+n,depth)) xt"


lemma [simp]: "shift 0 xt = xt"
(*<*)by(induct xt)(auto simp:shift_def)(*>*)

lemma [simp]: "shift n [] = []"
(*<*)by(simp add:shift_def)(*>*)

lemma [simp]: "shift n (xt1 @ xt2) = shift n xt1 @ shift n xt2"
(*<*)by(simp add:shift_def)(*>*)

lemma [simp]: "shift m (shift n xt) = shift (m+n) xt"
(*<*)by(induct xt)(auto simp:shift_def)(*>*)

lemma [simp]: "pcs (shift n xt) = {pc+n|pc. pc  pcs xt}"
(*<*)
apply(auto simp:shift_def pcs_def)
apply(rule_tac x = "x-n" in exI)
apply (force split:nat_diff_split)
done
(*>*)


lemma shift_compxE2:
shows "pc pc' d. shift pc (compxE2 e pc' d) = compxE2 e (pc' + pc) d"
and  "pc pc' d. shift pc (compxEs2 es pc' d) = compxEs2 es (pc' + pc) d"
(*<*)
apply(induct e and es rule: compxE2.induct compxEs2.induct)
apply(auto simp:shift_def ac_simps)
done
(*>*)


lemma compxE2_size_convs[simp]:
shows "n  0  compxE2 e n d = shift n (compxE2 e 0 d)"
and "n  0  compxEs2 es n d = shift n (compxEs2 es 0 d)"
(*<*)by(simp_all add:shift_compxE2)(*>*)

locale TC2 = TC1 +
  fixes Tr :: ty and mxs :: pc
begin

definition
  wt_instrs :: "instr list  ex_table  tyi' list  bool"
    ("( _, _ /[::]/ _)" [0,0,51] 50) where
  " is,xt [::] τs  size is < size τs  pcs xt  {0..<size is} 
  (pc< size is. P,Tr,mxs,size τs,xt  is!pc,pc :: τs)"

end

notation TC2.wt_instrs ("(_,_,_ / _, _ /[::]/ _)" [50,50,50,50,50,51] 50)

(*<*)
lemmas (in TC2) wt_defs =
  wt_instrs_def wt_instr_def app_def eff_def norm_eff_def
(*>*)

lemma (in TC2) [simp]: "τs  []   [],[] [::] τs"
(*<*) by (simp add: wt_defs) (*>*)

lemma [simp]: "eff i P pc et None = []"
(*<*)by (simp add: Effect.eff_def)(*>*)

(*<*)
declare split_comp_eq[simp del]
(*>*)

lemma wt_instr_appR:
 " P,T,m,mpc,xt  is!pc,pc :: τs;
    pc < size is; size is < size τs; mpc  size τs; mpc  mpc' 
   P,T,m,mpc',xt  is!pc,pc :: τs@τs'"
(*<*)by (fastforce simp:wt_instr_def app_def)(*>*)


lemma relevant_entries_shift [simp]:
  "relevant_entries P i (pc+n) (shift n xt) = shift n (relevant_entries P i pc xt)"
(*<*)
  apply (induct xt)
  apply (unfold relevant_entries_def shift_def)
   apply simp
  apply (auto simp add: is_relevant_entry_def)
  done
(*>*)


lemma [simp]:
  "xcpt_eff i P (pc+n) τ (shift n xt) =
   map (λ(pc,τ). (pc + n, τ)) (xcpt_eff i P pc τ xt)"
(*<*)
apply(simp add: xcpt_eff_def)
apply(cases τ)
apply(auto simp add: shift_def)
done
(*>*)


lemma  [simp]:
  "appi (i, P, pc, m, T, τ) 
   eff i P (pc+n) (shift n xt) (Some τ) =
   map (λ(pc,τ). (pc+n,τ)) (eff i P pc xt (Some τ))"
(*<*)
apply(simp add:eff_def norm_eff_def)
apply(cases "i",auto)
done
(*>*)


lemma [simp]:
  "xcpt_app i P (pc+n) mxs (shift n xt) τ = xcpt_app i P pc mxs xt τ"
(*<*)by (simp add: xcpt_app_def) (auto simp add: shift_def)(*>*)


lemma wt_instr_appL:
  " P,T,m,mpc,xt  i,pc :: τs; pc < size τs; mpc  size τs 
   P,T,m,mpc + size τs',shift (size τs') xt  i,pc+size τs' :: τs'@τs"
(*<*)
apply(auto simp:wt_instr_def app_def)
prefer 2 apply(fast)
prefer 2 apply(fast)
apply(cases "i",auto)
done
(*>*)


lemma wt_instr_Cons:
  " P,T,m,mpc - 1,[]  i,pc - 1 :: τs;
     0 < pc; 0 < mpc; pc < size τs + 1; mpc  size τs + 1 
   P,T,m,mpc,[]  i,pc :: τ#τs"
(*<*)
apply(drule wt_instr_appL[where τs' = "[τ]"])
apply arith
apply arith
apply (simp split:nat_diff_split_asm)
done
(*>*)


lemma wt_instr_append:
  " P,T,m,mpc - size τs',[]  i,pc - size τs' :: τs;
     size τs'  pc; size τs'  mpc; pc < size τs + size τs'; mpc  size τs + size τs' 
   P,T,m,mpc,[]  i,pc :: τs'@τs"
(*<*)
apply(drule wt_instr_appL[where τs' = τs'])
apply arith
apply arith
apply (simp split:nat_diff_split_asm)
done
(*>*)


lemma xcpt_app_pcs:
  "pc  pcs xt  xcpt_app i P pc mxs xt τ"
(*<*)
by (auto simp add: xcpt_app_def relevant_entries_def is_relevant_entry_def pcs_def)
(*>*)


lemma xcpt_eff_pcs:
  "pc  pcs xt  xcpt_eff i P pc τ xt = []"
(*<*)
by (cases τ)
   (auto simp add: is_relevant_entry_def xcpt_eff_def relevant_entries_def pcs_def
           intro!: filter_False)
(*>*)


lemma pcs_shift:
  "pc < n  pc  pcs (shift n xt)" 
(*<*)by (auto simp add: shift_def pcs_def)(*>*)


lemma wt_instr_appRx:
  " P,T,m,mpc,xt  is!pc,pc :: τs; pc < size is; size is < size τs; mpc  size τs 
   P,T,m,mpc,xt @ shift (size is) xt'  is!pc,pc :: τs"
(*<*)by (auto simp:wt_instr_def eff_def app_def xcpt_app_pcs xcpt_eff_pcs)(*>*)


lemma wt_instr_appLx: 
  " P,T,m,mpc,xt  i,pc :: τs; pc  pcs xt' 
   P,T,m,mpc,xt'@xt  i,pc :: τs"
(*<*)by (auto simp:wt_instr_def app_def eff_def xcpt_app_pcs xcpt_eff_pcs)(*>*)


lemma (in TC2) wt_instrs_extR:
  " is,xt [::] τs   is,xt [::] τs @ τs'"
(*<*)by(auto simp add:wt_instrs_def wt_instr_appR)(*>*)


lemma (in TC2) wt_instrs_ext:
  "  is1,xt1 [::] τs1@τs2;  is2,xt2 [::] τs2; size τs1 = size is1 
    is1@is2, xt1 @ shift (size is1) xt2 [::] τs1@τs2"
(*<*)
apply(clarsimp simp:wt_instrs_def)
apply(rule conjI, fastforce)
apply(rule conjI, fastforce)
apply clarsimp
apply(rule conjI, fastforce simp:wt_instr_appRx)
apply clarsimp
apply(erule_tac x = "pc - size is1" in allE)+
apply(thin_tac "P  Q" for P Q)
apply(erule impE, arith) 
apply(drule_tac τs' = "τs1" in wt_instr_appL)
  apply arith
 apply simp
apply(fastforce simp add:add.commute intro!: wt_instr_appLx)
done
(*>*)

corollary (in TC2) wt_instrs_ext2:
  "  is2,xt2 [::] τs2;  is1,xt1 [::] τs1@τs2; size τs1 = size is1 
    is1@is2, xt1 @ shift (size is1) xt2 [::] τs1@τs2"
(*<*)by(rule wt_instrs_ext)(*>*)


corollary (in TC2) wt_instrs_ext_prefix [trans]:
  "  is1,xt1 [::] τs1@τs2;  is2,xt2 [::] τs3;
     size τs1 = size is1; prefix τs3 τs2 
    is1@is2, xt1 @ shift (size is1) xt2 [::] τs1@τs2"
(*<*)by(bestsimp simp:prefix_def elim: wt_instrs_ext dest:wt_instrs_extR)(*>*)


corollary (in TC2) wt_instrs_app:
  assumes is1: " is1,xt1 [::] τs1@[τ]"
  assumes is2: " is2,xt2 [::] τ#τs2"
  assumes s: "size τs1 = size is1"
  shows " is1@is2, xt1@shift (size is1) xt2 [::] τs1@τ#τs2"
(*<*)
proof -
  from is1 have " is1,xt1 [::] (τs1@[τ])@τs2"
    by (rule wt_instrs_extR)
  hence " is1,xt1 [::] τs1@τ#τs2" by simp
  from this is2 s show ?thesis by (rule wt_instrs_ext) 
qed
(*>*)


corollary (in TC2) wt_instrs_app_last[trans]:
  "  is2,xt2 [::] τ#τs2;  is1,xt1 [::] τs1;
     last τs1 = τ;  size τs1 = size is1+1 
    is1@is2, xt1@shift (size is1) xt2 [::] τs1@τs2"
(*<*)
apply(cases τs1 rule:rev_cases)
 apply simp
apply(simp add:wt_instrs_app)
done
(*>*)


corollary (in TC2) wt_instrs_append_last[trans]:
  "  is,xt [::] τs; P,Tr,mxs,mpc,[]  i,pc :: τs;
     pc = size is; mpc = size τs; size is + 1 < size τs 
    is@[i],xt [::] τs"
(*<*)
apply(clarsimp simp add:wt_instrs_def)
apply(rule conjI, fastforce)
apply(fastforce intro!:wt_instr_appLx[where xt = "[]",simplified]
               dest!:less_antisym)
done
(*>*)


corollary (in TC2) wt_instrs_app2:
  "  is2,xt2 [::] τ'#τs2;   is1,xt1 [::] τ#τs1@[τ'];
     xt' = xt1 @ shift (size is1) xt2;  size τs1+1 = size is1 
    is1@is2,xt' [::] τ#τs1@τ'#τs2"
(*<*)using wt_instrs_app[where ?τs1.0 = "τ # τs1"] by simp (*>*)


corollary (in TC2) wt_instrs_app2_simp[trans,simp]:
  "  is2,xt2 [::] τ'#τs2;   is1,xt1 [::] τ#τs1@[τ']; size τs1+1 = size is1 
    is1@is2, xt1@shift (size is1) xt2 [::] τ#τs1@τ'#τs2"
(*<*)using wt_instrs_app[where ?τs1.0 = "τ # τs1"] by simp(*>*)


corollary (in TC2) wt_instrs_Cons[simp]:
  " τs  [];  [i],[] [::] [τ,τ'];  is,xt [::] τ'#τs 
    i#is,shift 1 xt [::] τ#τ'#τs"
(*<*)
using wt_instrs_app2[where ?is1.0 = "[i]" and ?τs1.0 = "[]" and ?is2.0 = "is"
                      and ?xt1.0 = "[]"]
by simp


corollary (in TC2) wt_instrs_Cons2[trans]:
  assumes τs: " is,xt [::] τs"
  assumes i: "P,Tr,mxs,mpc,[]  i,0 :: τ#τs"
  assumes mpc: "mpc = size τs + 1"
  shows " i#is,shift 1 xt [::] τ#τs"
(*<*)
proof -
  from τs have "τs  []" by (auto simp: wt_instrs_def)
  with mpc i have " [i],[] [::] [τ]@τs" by (simp add: wt_instrs_def)
  with τs show ?thesis by (fastforce dest: wt_instrs_ext)
qed
(*>*)


lemma (in TC2) wt_instrs_last_incr[trans]:
  "  is,xt [::] τs@[τ]; P  τ ≤' τ'    is,xt [::] τs@[τ']"
(*<*)
apply(clarsimp simp add:wt_instrs_def wt_instr_def)
apply(rule conjI)
apply(fastforce)
apply(clarsimp)
apply(rename_tac pc' tau')
apply(erule allE, erule (1) impE)
apply(clarsimp)
apply(drule (1) bspec)
apply(clarsimp)
apply(subgoal_tac "pc' = size τs")
prefer 2
apply(clarsimp simp:app_def)
apply(drule (1) bspec)
apply(clarsimp)
apply(auto elim!:sup_state_opt_trans)
done
(*>*)


lemma [iff]: "xcpt_app i P pc mxs [] τ"
(*<*)by (simp add: xcpt_app_def relevant_entries_def)(*>*)


lemma [simp]: "xcpt_eff i P pc τ [] = []"
(*<*)by (simp add: xcpt_eff_def relevant_entries_def)(*>*)


lemma (in TC2) wt_New:
  " is_class P C; size ST < mxs  
    [New C],[] [::] [tyi' ST E A, tyi' (Class C#ST) E A]"
(*<*)by(simp add:wt_defs tyi'_def)(*>*)


lemma (in TC2) wt_Cast:
  "is_class P C 
    [Checkcast C],[] [::] [tyi' (Class D # ST) E A, tyi' (Class C # ST) E A]"
(*<*)by(simp add: tyi'_def wt_defs)(*>*)


lemma (in TC2) wt_Push:
  " size ST < mxs; typeof v = Some T 
    [Push v],[] [::] [tyi' ST E A, tyi' (T#ST) E A]"
(*<*)by(simp add: tyi'_def wt_defs)(*>*)


lemma (in TC2) wt_Pop:
 " [Pop],[] [::] (tyi' (T#ST) E A # tyi' ST E A # τs)"
(*<*)by(simp add: tyi'_def wt_defs)(*>*)


lemma (in TC2) wt_CmpEq:
  " P  T1  T2  P  T2  T1
    [CmpEq],[] [::] [tyi' (T2 # T1 # ST) E A, tyi' (Boolean # ST) E A]"
(*<*) by(auto simp:tyi'_def wt_defs elim!: refTE not_refTE) (*>*)


lemma (in TC2) wt_IAdd:
  " [IAdd],[] [::] [tyi' (Integer#Integer#ST) E A, tyi' (Integer#ST) E A]"
(*<*)by(simp add:tyi'_def wt_defs)(*>*)


lemma (in TC2) wt_Load:
  " size ST < mxs; size E  mxl; i ∈∈ A; i < size E 
    [Load i],[] [::] [tyi' ST E A, tyi' (E!i # ST) E A]"
(*<*)by(auto simp add:tyi'_def wt_defs tyl_def hyperset_defs)(*>*)


lemma (in TC2) wt_Store:
 " P  T  E!i; i < size E; size E  mxl  
   [Store i],[] [::] [tyi' (T#ST) E A, tyi' ST E ({i}  A)]"
(*<*)
by(auto simp:hyperset_defs nth_list_update tyi'_def wt_defs tyl_def
        intro:list_all2_all_nthI)
(*>*)


lemma (in TC2) wt_Get:
 " P  C sees F:T in D  
   [Getfield F D],[] [::] [tyi' (Class C # ST) E A, tyi' (T # ST) E A]"
(*<*)by(auto simp: tyi'_def wt_defs dest: sees_field_idemp sees_field_decl_above)(*>*)


lemma (in TC2) wt_Put:
  " P  C sees F:T in D; P  T'  T  
   [Putfield F D],[] [::] [tyi' (T' # Class C # ST) E A, tyi' ST E A]"
(*<*)by(auto intro: sees_field_idemp sees_field_decl_above simp: tyi'_def wt_defs)(*>*)


lemma (in TC2) wt_Throw:
  " [Throw],[] [::] [tyi' (Class C # ST) E A, τ']"
(*<*)by(auto simp: tyi'_def wt_defs)(*>*)


lemma (in TC2) wt_IfFalse:
  " 2  i; nat i < size τs + 2; P  tyi' ST E A ≤' τs ! nat(i - 2) 
    [IfFalse i],[] [::] tyi' (Boolean # ST) E A # tyi' ST E A # τs"
(*<*)
by(simp add: tyi'_def wt_defs eval_nat_numeral nat_diff_distrib)
(*>*)


lemma wt_Goto:
 " 0  int pc + i; nat (int pc + i) < size τs; size τs  mpc;
    P  τs!pc ≤' τs ! nat (int pc + i) 
  P,T,mxs,mpc,[]  Goto i,pc :: τs"
(*<*)by(clarsimp simp add: TC2.wt_defs)(*>*)


lemma (in TC2) wt_Invoke:
  " size es = size Ts'; P  C sees M: TsT = m in D; P  Ts' [≤] Ts 
    [Invoke M (size es)],[] [::] [tyi' (rev Ts' @ Class C # ST) E A, tyi' (T#ST) E A]"
(*<*)by(fastforce simp add: tyi'_def wt_defs)(*>*)


corollary (in TC2) wt_instrs_app3[simp]:
  "  is2,[] [::] (τ' # τs2);   is1,xt1 [::] τ # τs1 @ [τ']; size τs1+1 = size is1
    (is1 @ is2),xt1 [::] τ # τs1 @ τ' # τs2"
(*<*)using wt_instrs_app2[where ?xt2.0 = "[]"] by (simp add:shift_def)(*>*)


corollary (in TC2) wt_instrs_Cons3[simp]:
  " τs  [];  [i],[] [::] [τ,τ'];  is,[] [::] τ'#τs 
    (i # is),[] [::] τ # τ' # τs"
(*<*)
using wt_instrs_Cons[where ?xt = "[]"]
by (simp add:shift_def)

(*<*)
declare nth_append[simp del]
declare [[simproc del: list_to_set_comprehension]]
(*>*)

lemma (in TC2) wt_instrs_xapp[trans]:
  "  is1 @ is2, xt [::] τs1 @ tyi' (Class C # ST) E A # τs2;
     τ  set τs1. ST' LT'. τ = Some(ST',LT')  
      size ST  size ST'  P  Some (drop (size ST' - size ST) ST',LT') ≤' tyi' ST E A;
     size is1 = size τs1; is_class P C; size ST < mxs   
   is1 @ is2, xt @ [(0,size is1 - 1,C,size is1,size ST)] [::] τs1 @ tyi' (Class C # ST) E A # τs2"
(*<*)
apply(simp add:wt_instrs_def)
apply(rule conjI)
 apply(clarsimp)
 apply arith
apply clarsimp
apply(erule allE, erule (1) impE)
apply(clarsimp simp add: wt_instr_def app_def eff_def)
apply(rule conjI)
 apply (thin_tac "x A  B. P x" for A B P)
 apply (thin_tac "x A  B. P x" for A B P)
 apply (clarsimp simp add: xcpt_app_def relevant_entries_def)
 apply (simp add: nth_append is_relevant_entry_def split!: if_splits)
  apply (drule_tac x="τs1!pc" in bspec)
   apply (blast intro: nth_mem) 
  apply fastforce
apply (rule conjI)
 apply clarsimp
 apply (erule disjE, blast)
 apply (erule disjE, blast)
 apply (clarsimp simp add: xcpt_eff_def relevant_entries_def split: if_split_asm)
apply clarsimp
apply (erule disjE, blast)
apply (erule disjE, blast)
apply (clarsimp simp add: xcpt_eff_def relevant_entries_def split: if_split_asm)
apply (simp add: nth_append is_relevant_entry_def split: if_split_asm)
 apply (drule_tac x = "τs1!pc" in bspec)
  apply (blast intro: nth_mem) 
 apply (fastforce simp add: tyi'_def)
done

declare [[simproc add: list_to_set_comprehension]]
declare nth_append[simp]
(*>*)

lemma drop_Cons_Suc:
  "xs. drop n xs = y#ys  drop (Suc n) xs = ys"
  apply (induct n)
   apply simp
  apply (simp add: drop_Suc)
  done

lemma drop_mess:
  "Suc (length xs0)  length xs; drop (length xs - Suc (length xs0)) xs = x # xs0 
   drop (length xs - length xs0) xs = xs0"
apply (cases xs)
 apply simp
apply (simp add: Suc_diff_le)
apply (case_tac "length list - length xs0")
 apply simp
apply (simp add: drop_Cons_Suc)
done

(*<*)
declare (in TC0)
  after_def[simp] pair_eq_tyi'_conv[simp]
(*>*)

lemma (in TC1) compT_ST_prefix:
 "E A ST0. (ST,LT)  set(compT E A ST0 e)  
  size ST0  size ST  drop (size ST - size ST0) ST = ST0"
and
 "E A ST0. (ST,LT)  set(compTs E A ST0 es)  
  size ST0  size ST  drop (size ST - size ST0) ST = ST0"
(*<*)
proof(induct e and es rule: compT.induct compTs.induct)
  case (FAss e1 F D e2)
  moreover {
    let ?ST0 = "ty E e1 # ST0"
    fix A assume "(ST, LT)  set (compT E A ?ST0 e2)"
    with FAss
    have "length ?ST0  length ST  drop (size ST - size ?ST0) ST = ?ST0" by blast
    hence ?case  by (clarsimp simp add: drop_mess)
  }
  ultimately show ?case by auto
next
  case TryCatch thus ?case by auto
next
  case Block thus ?case by auto
next
  case Seq thus ?case by auto
next
  case While thus ?case by auto
next
  case Cond thus ?case by auto
next
  case (Call e M es)
  moreover {
    let ?ST0 = "ty E e # ST0"
    fix A assume "(ST, LT)  set (compTs E A ?ST0 es)"
    with Call
    have "length ?ST0  length ST  drop (size ST - size ?ST0) ST = ?ST0" by blast
    hence ?case  by (clarsimp simp add: drop_mess)
  }
  ultimately show ?case by auto
next
  case (Cons_exp e es)
  moreover {
    let ?ST0 = "ty E e # ST0"
    fix A assume "(ST, LT)  set (compTs E A ?ST0 es)"
    with Cons_exp
    have "length ?ST0  length ST  drop (size ST - size ?ST0) ST = ?ST0" by blast
    hence ?case  by (clarsimp simp add: drop_mess)
  }
  ultimately show ?case by auto
next
  case (BinOp e1 bop e2)
  moreover {
    let ?ST0 = "ty E e1 # ST0"
    fix A assume "(ST, LT)  set (compT E A ?ST0 e2)"
    with BinOp 
    have "length ?ST0  length ST  drop (size ST - size ?ST0) ST = ?ST0" by blast
    hence ?case by (clarsimp simp add: drop_mess)
  }
  ultimately show ?case by auto
next
  case new thus ?case by auto
next
  case Val thus ?case by auto    
next
  case Cast thus ?case by auto
next
  case Var thus ?case by auto
next
  case LAss thus ?case by auto
next
  case throw thus ?case by auto
next
  case FAcc thus ?case by auto
next
  case Nil_exp thus ?case by auto
qed 

declare (in TC0) 
  after_def[simp del] pair_eq_tyi'_conv[simp del]
(*>*)

(* FIXME *)
lemma fun_of_simp [simp]: "fun_of S x y = ((x,y)  S)" 
(*<*) by (simp add: fun_of_def)(*>*)

theorem (in TC2) compT_wt_instrs: "E T A ST.
   P,E 1 e :: T; 𝒟 e A;e (size E); 
    size ST + max_stack e  mxs; size E + max_vars e  mxl 
    compE2 e, compxE2 e 0 (size ST) [::]
                 tyi' ST E A # compT E A ST e @ [after E A ST e]"
(*<*)(is "E T A ST. PROP ?P e E T A ST")(*>*)

and "E Ts A ST.
   P,E 1 es[::]Ts;  𝒟s es A; ℬs es (size E); 
    size ST + max_stacks es  mxs; size E + max_varss es  mxl 
   let τs = tyi' ST E A # compTs E A ST es in
        compEs2 es,compxEs2 es 0 (size ST) [::] τs 
       last τs = tyi' (rev Ts @ ST) E (A  𝒜s es)"
(*<*)
(is "E Ts A ST. PROP ?Ps es E Ts A ST")
proof(induct e and es rule: compxE2.induct compxEs2.induct)
  case (TryCatch e1 C i e2)
  hence [simp]: "i = size E" by simp
  have wt1: "P,E 1 e1 :: T" and wt2: "P,E@[Class C] 1 e2 :: T"
    and "class": "is_class P C" using TryCatch by auto
  let ?A1 = "A  𝒜 e1" let ?Ai = "A  {i}" let ?Ei = "E @ [Class C]"
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let 1 = "tyi' (T#ST) E ?A1" let 2 = "tyi' (Class C#ST) E A"
  let 3 = "tyi' ST ?Ei ?Ai" let ?τs2 = "compT ?Ei ?Ai ST e2"
  let 2' = "tyi' (T#ST) ?Ei (?Ai  𝒜 e2)"
  let ?τ' = "tyi' (T#ST) E (A  𝒜 e1  (𝒜 e2  i))"
  let ?go = "Goto (int(size(compE2 e2)) + 2)"
  have "PROP ?P e2 ?Ei T ?Ai ST" by fact
  hence " compE2 e2,compxE2 e2 0 (size ST) [::] (3 # ?τs2) @ [2']"
    using TryCatch.prems by(auto simp:after_def)
  also have "?Ai  𝒜 e2 = (A  𝒜 e2)  {size E}"
    by(fastforce simp:hyperset_defs)
  also have "P  tyi' (T#ST) ?Ei  ≤' tyi' (T#ST) E (A  𝒜 e2)"
    by(simp add:hyperset_defs tyl_incr tyi'_def)
  also have "P   ≤' tyi' (T#ST) E (A  𝒜 e1  (𝒜 e2  i))"
    by(auto intro!: tyl_antimono simp:hyperset_defs tyi'_def)
  also have "(3 # ?τs2) @ [?τ'] = 3 # ?τs2 @ [?τ']" by simp
  also have " [Store i],[] [::] 2 # [] @ [3]"
    using TryCatch.prems
    by(auto simp:nth_list_update wt_defs tyi'_def tyl_def
      list_all2_conv_all_nth hyperset_defs)
  also have "[] @ (3 # ?τs2 @ [?τ']) = (3 # ?τs2 @ [?τ'])" by simp
  also have "P,Tr,mxs,size(compE2 e2)+3,[]  ?go,0 :: 1#2#3#?τs2 @ [?τ']"
    by (auto simp: hyperset_defs tyi'_def wt_defs nth_Cons nat_add_distrib
      fun_of_def intro: tyl_antimono list_all2_refl split:nat.split)
  also have " compE2 e1,compxE2 e1 0 (size ST) [::]  # ?τs1 @ [1]"
    using TryCatch by(auto simp:after_def)
  also have " # ?τs1 @ 1 # 2 # 3 # ?τs2 @ [?τ'] =
             ( # ?τs1 @ [1]) @ 2 # 3 # ?τs2 @ [?τ']" by simp
  also have "compE2 e1 @ ?go  # [Store i] @ compE2 e2 =
             (compE2 e1 @ [?go]) @ (Store i # compE2 e2)" by simp
  also 
  let "?Q τ" = "ST' LT'. τ = (ST', LT')  
    size ST  size ST'  P  Some (drop (size ST' - size ST) ST',LT') ≤' tyi' ST E A"
  {
    have "?Q (tyi' ST E A)" by (clarsimp simp add: tyi'_def)
    moreover have "?Q (tyi' (T # ST) E ?A1)" 
      by (fastforce simp add: tyi'_def hyperset_defs intro!: tyl_antimono)
    moreover have "τ. τ  set (compT E A ST e1)  ?Q τ" using TryCatch.prems
      by clarsimp (frule compT_ST_prefix,
                   fastforce dest!: compT_LT_prefix simp add: tyi'_def)
    ultimately
    have "τset (tyi' ST E A # compT E A ST e1 @ [tyi' (T # ST) E ?A1]). ?Q τ" 
      by auto
  }
  also from TryCatch.prems max_stack1[of e1] have "size ST + 1  mxs" by auto
  ultimately show ?case using wt1 wt2 TryCatch.prems "class"
    by (simp add:after_def)
next
  case new thus ?case by(auto simp add:after_def wt_New)
next
  case (BinOp e1 bop e2) 
  let ?op = "case bop of Eq  [CmpEq] | Add  [IAdd]"
  have T: "P,E 1 e1 «bop» e2 :: T" by fact
  then obtain T1 T2 where T1: "P,E 1 e1 :: T1" and T2: "P,E 1 e2 :: T2" and 
    bopT: "case bop of Eq  (P  T1  T2  P  T2  T1)  T = Boolean 
                    | Add  T1 = Integer  T2 = Integer  T = Integer" by auto
  let ?A1 = "A  𝒜 e1" let ?A2 = "?A1  𝒜 e2"
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let 1 = "tyi' (T1#ST) E ?A1" let ?τs2 = "compT E ?A1 (T1#ST) e2"
  let 2 = "tyi' (T2#T1#ST) E ?A2" let ?τ' = "tyi' (T#ST) E ?A2"
  from bopT have " ?op,[] [::] [2,?τ']" 
    by (cases bop) (auto simp add: wt_CmpEq wt_IAdd)
  also have "PROP ?P e2 E T2 ?A1 (T1#ST)" by fact
  with BinOp.prems T2 
  have " compE2 e2, compxE2 e2 0 (size (T1#ST)) [::] 1#?τs2@[2]" 
    by (auto simp: after_def)
  also from BinOp T1 have " compE2 e1, compxE2 e1 0 (size ST) [::] #?τs1@[1]" 
    by (auto simp: after_def)
  finally show ?case using T T1 T2 by (simp add: after_def hyperUn_assoc)
next
  case (Cons_exp e es)
  have "P,E 1 e # es [::] Ts" by fact
  then obtain Te Ts' where 
    Te: "P,E 1 e :: Te" and Ts': "P,E 1 es [::] Ts'" and
    Ts: "Ts = Te#Ts'" by auto
  let ?Ae = "A  𝒜 e"  
  let  = "tyi' ST E A" let ?τse = "compT E A ST e"  
  let e = "tyi' (Te#ST) E ?Ae" let ?τs' = "compTs E ?Ae (Te#ST) es"
  let ?τs = " # ?τse @ (e # ?τs')"
  have Ps: "PROP ?Ps es E Ts' ?Ae (Te#ST)" by fact
  with Cons_exp.prems Te Ts'
  have " compEs2 es, compxEs2 es 0 (size (Te#ST)) [::] e#?τs'" by (simp add: after_def)
  also from Cons_exp Te have " compE2 e, compxE2 e 0 (size ST) [::] #?τse@[e]" 
    by (auto simp: after_def)
  moreover
  from Ps Cons_exp.prems Te Ts' Ts
  have "last ?τs = tyi' (rev Ts@ST) E (?Ae  𝒜s es)" by simp
  ultimately show ?case using Te by (simp add: after_def hyperUn_assoc)
next
  case (FAss e1 F D e2)
  hence Void: "P,E 1 e1F{D} := e2 :: Void" by auto
  then obtain C T T' where    
    C: "P,E 1 e1 :: Class C" and sees: "P  C sees F:T in D" and
    T': "P,E 1 e2 :: T'" and T'_T: "P  T'  T" by auto
  let ?A1 = "A  𝒜 e1" let ?A2 = "?A1  𝒜 e2"  
  let  = "tyi' ST E A" let ?τs1 = "compT E A ST e1"
  let 1 = "tyi' (Class C#ST) E ?A1" let ?τs2 = "compT E ?A1 (Class C#ST) e2"
  let 2 = "tyi' (T'#Class C#ST) E ?A2" let 3 = "tyi' ST E ?A2"
  let ?τ' = "tyi' (Void#ST) E ?A2"
  from FAss.prems sees T'_T 
  have " [Putfield F D,Push Unit],[] [::] [2,3,?τ']"
    by (fastforce simp add: wt_Push wt_Put)
  also have "PROP ?P e2 E T' ?A1 (Class C#ST)" by fact
  with FAss.prems T' 
  have " compE2 e2, compxE2 e2 0 (size ST+1) [::] 1#?τs2@[2]"
    by (auto simp add: after_def hyperUn_assoc) 
  also from FAss C have " compE2 e1, compxE2 e1 0 (size ST) [::] #?τs1@[1]" 
    by (auto simp add: after_def)
  finally show ?case using Void C T' by (simp add: after_def hyperUn_assoc) 
next
  case Val thus ?case by(auto simp:after_def wt_Push)
next
  case Cast thus ?case by (auto simp:after_def wt_Cast)
next
  case (Block i Ti e)
  let ?τs = "tyi' ST E A # compT (E @ [Ti]) (Ai) ST e"
  have IH: "PROP ?P e (E@[Ti]) T (Ai) ST" by fact
  hence " compE2 e, compxE2 e 0 (size ST) [::]
         ?τs @ [tyi' (T#ST) (E@[Ti]) (A(size E)  𝒜 e)]"
    using Block.prems by (auto simp add: after_def)
  also have "P  tyi' (T # ST) (E@[Ti]) (A  size E  𝒜 e) ≤'
                 tyi' (T # ST) (E@[Ti]) ((A  𝒜 e)  size E)"
     by(auto simp add:hyperset_defs intro: tyi'_antimono)
  also have " = tyi' (T # ST) E (A  𝒜 e)" by simp
  also have "P   ≤' tyi' (T # ST) E (A  (𝒜 e  i))"
     by(auto simp add:hyperset_defs intro: tyi'_antimono)
  finally show ?case using Block.prems by(simp add: after_def)
next
  case Var thus ?case by(auto simp:after_def wt_Load)
next
  case FAcc thus ?case by(auto simp:after_def wt_Get)
next
  case (LAss i e) thus ?case using max_stack1[of e]
    by(auto simp: hyper_insert_comm after_def wt_Store wt_Push)
next
  case Nil_exp thus ?case by auto
next
  case throw thus ?case by(auto simp add: after_def wt_Throw)
next
  case (While e c)
  obtain Tc where wte: "P,E 1 e :: Boolean" and wtc: "P,E 1 c :: Tc"
    and [simp]: "T = Void" using While by auto
  have [simp]: "ty E (while (e) c) = Void" using While by simp
  let ?A0 = "A  𝒜 e" let ?A1 = "?A0  𝒜 c"
  let  = "tyi' ST E A" let ?τse = "compT E A ST e"
  let e = "tyi' (Boolean#ST) E ?A0" let 1 = "tyi' ST E ?A0"
  let ?τsc = "compT E ?A0 ST c" let c = "tyi' (Tc#ST) E ?A1"
  let 2 = "tyi' ST E ?A1" let ?τ' = "tyi' (Void#ST) E ?A0"
  let ?τs = "( # ?τse @ [e]) @ 1 # ?τsc @ [c, 2, 1, ?τ']"
  have " [],[] [::] [] @ ?τs" by(simp add:wt_instrs_def)
  also
  have "PROP ?P e E Boolean A ST" by fact
  hence " compE2 e,compxE2 e 0 (size ST) [::]  # ?τse @ [e]"
    using While.prems by (auto simp:after_def)
  also
  have "[] @ ?τs = ( # ?τse) @ e # 1 # ?τsc @ [c,2,1,?τ']" by simp
  also
  let ?ne = "size(compE2 e)"  let ?nc = "size(compE2 c)"
  let ?if = "IfFalse (int ?nc + 3)"
  have " [?if],[] [::] e # 1 # ?τsc @ [c, 2, 1, ?τ']"
    by(simp add: wt_instr_Cons wt_instr_append wt_IfFalse
                 nat_add_distrib split: nat_diff_split)
  also
  have "( # ?τse) @ (e # 1 # ?τsc @ [c, 2, 1, ?τ']) = ?τs" by simp
  also
  have "PROP ?P c E Tc ?A0 ST" by fact
  hence " compE2 c,compxE2 c 0 (size ST) [::] 1 # ?τsc @ [c]"
    using While.prems wtc by (auto simp:after_def)
  also have "?τs = ( # ?τse @ [e,1] @ ?τsc) @ [c,2,1,?τ']" by simp
  also have " [Pop],[] [::] [c, 2]"  by(simp add:wt_Pop)
  also have "( # ?τse @ [e,1] @ ?τsc) @ [c,2,1,?τ'] = ?τs" by simp
  also let ?go = "Goto (-int(?nc+?ne+2))"
  have "P  2 ≤' " by(fastforce intro: tyi'_antimono simp: hyperset_defs)
  hence "P,Tr,mxs,size ?τs,[]  ?go,?ne+?nc+2 :: ?τs"
    by(simp add: wt_Goto split: nat_diff_split)
  also have "?τs = ( # ?τse @ [e,1] @ ?τsc @ [c, 2]) @ [1, ?τ']"
    by simp
  also have " [Push Unit],[] [::] [1,?τ']"
    using While.prems max_stack1[of c] by(auto simp add:wt_Push)
  finally show ?case using wtc wte
    by (simp add:after_def)
next
  case (Cond e e1 e2)
  obtain T1 T2 where wte: "P,E 1 e :: Boolean"
    and wt1: "P,E 1 e1 :: T1" and wt2: "P,E 1 e2 :: T2"
    and sub1: "P  T1  T" and sub2: "P  T2  T"
    using Cond by auto
  have [simp]: "ty E (if (e) e1 else e2) = T" using Cond by simp
  let ?A0 = "A  𝒜 e" let ?A2 = "?A0  𝒜 e2" let ?A1 = "?A0  𝒜 e1"
  let ?A' = "?A0  𝒜 e1  𝒜 e2"
  let 2 = "tyi' ST E ?A0" let ?τ' = "tyi' (T#ST) E ?A'"
  let ?τs2 = "compT E ?A0 ST e2"
  have "PROP ?P e2 E T2 ?A0 ST" by fact
  hence " compE2 e2, compxE2 e2 0 (size ST) [::] (2#?τs2) @ [tyi' (T2#ST) E ?A2]"
    using Cond.prems wt2 by(auto simp add:after_def)
  also have "P  tyi' (T2#ST) E ?A2 ≤' ?τ'" using sub2
    by(auto simp add: hyperset_defs tyi'_def intro!: tyl_antimono)
  also
  let 3 = "tyi' (T1 # ST) E ?A1"
  let ?g2 = "Goto(int (size (compE2 e2) + 1))"
  from sub1 have "P,Tr,mxs,size(compE2 e2)+2,[]  ?g2,0 :: 3#(2#?τs2)@[?τ']"
    by(auto simp: hyperset_defs wt_defs nth_Cons tyi'_def
             split:nat.split intro!: tyl_antimono)
  also
  let ?τs1 = "compT E ?A0 ST e1"
  have "PROP ?P e1 E T1 ?A0 ST" by fact
  hence " compE2 e1,compxE2 e1 0 (size ST) [::] 2 # ?τs1 @ [3]"
    using Cond.prems wt1 by(auto simp add:after_def)
  also
  let ?τs12 = "2 # ?τs1 @ 3 # (2 # ?τs2) @ [?τ']"
  let 1 = "tyi' (Boolean#ST) E ?A0"
  let ?g1 = "IfFalse(int (size (compE2 e1) + 2))"
  let ?code = "compE2 e1 @ ?g2 # compE2 e2"
  have " [?g1],[] [::] [1] @ ?τs12"
    by(simp add: wt_IfFalse nat_add_distrib split:nat_diff_split)
  also (wt_instrs_ext2) have "[1] @ ?τs12 = 1 # ?τs12" by simp also
  let  = "tyi' ST E A"
  have "PROP ?P e E Boolean A ST" by fact
  hence " compE2 e, compxE2 e 0 (size ST) [::]  # compT E A ST e @ [1]"
    using Cond.prems wte by(auto simp add:after_def)
  finally show ?case using wte wt1 wt2 by(simp add:after_def hyperUn_assoc)
next
  case (Call e M es)
  obtain C D Ts m Ts' where C: "P,E 1 e :: Class C"
    and "method": "P  C sees M:Ts  T = m in D"
    and wtes: "P,E 1 es [::] Ts'" and subs: "P  Ts' [≤] Ts"
    using Call.prems by auto
  from wtes have same_size: "size es = size Ts'" by(rule WTs1_same_size)
  let ?A0 = "A  𝒜 e" let ?A1 = "?A0  𝒜s es"
  let  = "tyi' ST E A" let ?τse = "compT E A ST e"
  let e = "tyi' (Class C # ST) E ?A0"
  let ?τses = "compTs E ?A0 (Class C # ST) es"
  let 1 = "tyi' (rev Ts' @ Class C # ST) E ?A1"
  let ?τ' = "tyi' (T # ST) E ?A1"
  have " [Invoke M (size es)],[] [::] [1,?τ']"
    by(rule wt_Invoke[OF same_size "method" subs])
  also
  have "PROP ?Ps es E Ts' ?A0 (Class C # ST)" by fact
  hence " compEs2 es,compxEs2 es 0 (size ST+1) [::] e # ?τses"
        "last (e # ?τses) = 1"
    using Call.prems wtes by(auto simp add:after_def)
  also have "(e # ?τses) @ [?τ'] = e # ?τses @ [?τ']" by simp
  also have " compE2 e,compxE2 e 0 (size ST) [::]  # ?τse @ [e]"
    using Call C by(auto simp add:after_def)
  finally show ?case using Call.prems C by(simp add:after_def hyperUn_assoc)
next
  case Seq thus ?case
    by(auto simp:after_def)
      (fastforce simp:wt_Push wt_Pop hyperUn_assoc
                intro:wt_instrs_app2 wt_instrs_Cons)
qed
(*>*)


lemma [simp]: "types (compP f P) = types P"
(*<*)by auto(*>*)

lemma [simp]: "states (compP f P) mxs mxl = states P mxs mxl"
(*<*)by (simp add: JVM_states_unfold)(*>*)

lemma [simp]: "appi (i, compP f P, pc, mpc, T, τ) = appi (i, P, pc, mpc, T, τ)"
(*<*)
  apply (cases τ)  
  apply (cases i)
  apply auto
   apply (fastforce dest!: sees_method_compPD)
  apply (force dest: sees_method_compP)
  done
(*>*)
  
lemma [simp]: "is_relevant_entry (compP f P) i = is_relevant_entry P i"
(*<*)
  apply (rule ext)+
  apply (unfold is_relevant_entry_def)
  apply (cases i)
  apply auto
  done
(*>*)

lemma [simp]: "relevant_entries (compP f P) i pc xt = relevant_entries P i pc xt"
(*<*) by (simp add: relevant_entries_def)(*>*)

lemma [simp]: "app i (compP f P) mpc T pc mxl xt τ = app i P mpc T pc mxl xt τ"
(*<*)
  apply (simp add: app_def xcpt_app_def eff_def xcpt_eff_def norm_eff_def)
  apply (fastforce simp add: image_def)
  done
(*>*)

lemma [simp]: "app i P mpc T pc mxl xt τ  eff i (compP f P) pc xt τ = eff i P pc xt τ"
(*<*)
  apply (clarsimp simp add: eff_def norm_eff_def xcpt_eff_def app_def)
  apply (cases i)
  apply auto
  done
(*>*)

lemma [simp]: "subtype (compP f P) = subtype P"
(*<*)
  apply (rule ext)+
  apply (simp)
  done
(*>*)
  
lemma [simp]: "compP f P  τ ≤' τ' = P  τ ≤' τ'"
(*<*) by (simp add: sup_state_opt_def sup_state_def sup_ty_opt_def)(*>*)

lemma [simp]: "compP f P,T,mpc,mxl,xt  i,pc :: τs = P,T,mpc,mxl,xt  i,pc :: τs"
(*<*)by (simp add: wt_instr_def cong: conj_cong)(*>*)

declare TC1.compT_sizes[simp]  TC0.ty_def2[simp]

context TC2
begin

lemma compT_method:
  fixes e and A and C and Ts and mxl0
  defines [simp]: "E  Class C # Ts"
    and [simp]: "A  {..size Ts}"
    and [simp]: "A'  A  𝒜 e"
    and [simp]: "mxl0  max_vars e"
  assumes mxs: "max_stack e = mxs"
    and mxl: "Suc (length Ts + max_vars e) = mxl"
  assumes assm: "wf_prog p P" "P,E 1 e :: T" "𝒟 e A" "ℬ e (size E)"
    "set E  types P" "P  T  Tr"
  shows "wt_method (compP2 P) C Ts Tr mxs mxl0 (compE2 e @ [Return])
    (compxE2 e 0 0) (tyi' [] E A # compTa E A [] e)"
(*<*)
using assms apply (simp add: wt_method_def compTa_def after_def mxl)
apply (rule conjI)
apply (simp add: check_types_def OK_tyi'_in_statesI)
apply (rule conjI)
apply (drule (1) WT1_is_type)
apply simp
apply (insert max_stack1 [of e])
apply (rule OK_tyi'_in_statesI) apply (simp_all add: mxs)[3]
apply (erule compT_states(1))
apply assumption
apply (simp_all add: mxs mxl)[4]
apply (rule conjI)
apply (auto simp add: wt_start_def tyi'_def tyl_def list_all2_conv_all_nth
  nth_Cons mxl split: nat.split dest: less_antisym)[1]
apply (frule (1) TC2.compT_wt_instrs [of P _ _ _ _ "[]" "max_stack e" "Suc (length Ts + max_vars e)" Tr])
apply simp_all
apply (clarsimp simp: after_def)
apply hypsubst_thin
apply (rule conjI)
apply (clarsimp simp: wt_instrs_def after_def mxl mxs)
apply clarsimp
apply (drule (1) less_antisym)
apply (clarsimp simp: wt_defs xcpt_app_pcs xcpt_eff_pcs tyi'_def)
done
(*>*)

end

definition compTP :: "J1_prog  tyP" where
  "compTP P C M = (
  let (D,Ts,T,e) = method P C M;
       E = Class C # Ts;
       A = {..size Ts};
       mxl = 1 + size Ts + max_vars e
  in  (TC0.tyi' mxl [] E A # TC1.compTa P mxl E A [] e))"

theorem wt_compP2:
  "wf_J1_prog P  wf_jvm_prog (compP2 P)"
(*<*)
  apply (simp add: wf_jvm_prog_def wf_jvm_prog_phi_def)
  apply(rule_tac x = "compTP P" in exI)
  apply (rule wf_prog_compPI)
   prefer 2 apply assumption
  apply (clarsimp simp add: wf_mdecl_def)
  apply (simp add: compTP_def)
  apply (rule TC2.compT_method [simplified])
       apply (rule refl)
       apply (rule refl)
       apply assumption
       apply assumption
       apply assumption
       apply assumption
    apply (drule (1) sees_wf_mdecl)
    apply (simp add: wf_mdecl_def)
   apply (blast intro: sees_method_is_class)
  apply assumption
  done
(*>*)

theorem wt_J2JVM:
  "wf_J_prog P  wf_jvm_prog (J2JVM P)"
(*<*)
apply(simp only:o_def J2JVM_def)
apply(blast intro:wt_compP2 compP1_pres_wf)
done

end

Theory Jinja

theory Jinja
imports
  "J/TypeSafe"
  "J/Annotate"
  (* FIXME "Example" *)
  "J/execute_Bigstep"
  "J/execute_WellType"
  "JVM/JVMDefensive"
  "JVM/JVMListExample"
  "BV/BVExec"
  "BV/LBVJVM"
  "BV/BVNoTypeError"
  "BV/BVExample"
  "Compiler/TypeComp"
begin

end